Trouble with Haskell GUI programming and lazy evaluation - user-interface

In an attempt to use Haskell for a graphical application, I've had a lot of trouble getting the GUI to evaluate in an eager fashion.
For example, I sometimes attempt to create widgets somewhere in the program, package it and send it to other components of my program.
This doesn't work out that well, usually never resulting in the widget getting displayed due to lazy evaluation discarding the widget before it gets a chance to be put on the screen.
So I wanted to know, other than putting in a bunch of seq and other variations to encourage eager evaluation, can/how does one deal with this issue?
I've searched for an answer, but couldn't really find anything related to this line of questioning.
EDIT: sample code
The code below produced an empty window.
{-# LANGUAGE RecursiveDo #-}
-- allows recursive do notation
-- mdo
-- ...
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Map.Strict as Map
import qualified Data.List as List
import System.Random
import Graphics.UI.WX hiding (Event)
import Graphics.UI.WXCore as WXCore
import Reactive.Banana
import Reactive.Banana.WX
boardWidth, boardHeight :: Int
boardWidth = 41
boardHeight = 81
main :: IO ()
main = start tetris
tetris = do
ff <- frame [text := "Tetris"
,bgcolor := white
,resizeable:= False]
p <- panel ff []
set ff [ layout := minsize (sz 100 100) $ widget p]
pps <- return $ Map.fromList $ map (\l#(x,y) -> (l, button p []))
[(x,y) | x <- [1..(boardWidth `div` 2)], y <- [1..(boardHeight `div` 2)]]
-- p <- pps Map.! (1,2)
d <- return $ map (\(x,y_m) -> y_m >>= (\y -> set ff [ color := white, layout := minsize (sz 300 300) $ widget y ])) $ Map.toList pps
-- let networkDescription :: Moment IO ()
return ff
The line p <- pps Map.! (1,2) results in the tile at 1, 2 to display without the proper size.

This doesn't work out that well, usually never resulting in the widget getting displayed due to lazy evaluation discarding the widget before it gets a chance to be put on the screen.
As Thomas M. DuBuisson suggests, that is a misdiagnosis: the issue here doesn't have to do with lazy evaluation (and in any case lazy evaluation wouldn't discard a value you actually tried to use). Let's have a look at the line at which you'd supposedly add the buttons to the panel:
d <- return $ map (\(x,y_m) ->
y_m >>= (\y -> set ff [ color := white, layout := minsize (sz 300 300) $ widget y ]))
$ Map.toList pps
The type of Map.toList pps is [((Int, Int), IO (Button ())]. Your use of map changes it into [IO ()] (cf. the type of set), a list of IO actions. In effect, you are setting up the actions that add the buttons, but you never actually run them. To do that, you want traverse_ from Data.Foldable instead of map:
traverse_ (\(x,y_m) ->
y_m >>= (\y -> set ff [ color := white, layout := minsize (sz 300 300) $ widget y ]))
$ Map.toList pps
(For more on traverse_ and its cousin traverse, see this answer, as well as the other answers to the parent question.)
Note that, unless I'm badly misreading the WX-specific code, this still won't do what you want. As each IO action you generate for a list element resets the layout of the frame, you'll end up with only the last button in the frame. To get a sensible layout, you'll have to actually use the coordinate values, as well as the WX layout combinators to set up a single layout with all buttons. Cf. the Graphics.UI.WX.Layout documentation.
On a final note, code like this in a do-block...
bar <- return foo
... is always redundant: it can be replaced by:
let bar = foo
In your case, doing that would have made it much more obvious that you weren't actually running the actions.
(Your uses of Map.fromList and Map.toList are also redundant, but I guess you already suspected that.)

Related

Switching to an event wrapped in monadic context

My specific problem is like this:
Given an Event t [a] and an Event t () (let's say it's a tick event), I want to produce an Event t a, that is, an event that is giving me consecutive items from input list for every occurence of tick event.
Reflex has following helper:
zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
which is doing exactly what I want, but does not take an event as an input, but just a list. Given that I have an Event t [a], I thought I could produce an event containing event and just switch, but the problem is that zipListWithEven operates in monadic context, therefore I can get:
Event t (m (Event t a))
which is something that switch primitive does not accept.
Now, maybe I'm approaching it in wrong way, so here's my general problem. Given an event that's producing list of coordinates and tick event, I want to produce an event that I can "use" to move an object along the coordinates. So each time tick fires, the position is updated. And each time I update the coordinates list, it begins to produce positions from that new list.
I'm not entirely sure if I understand the semantics of your desired functions correctly, but in the reactive-banana library, I would solve the problem like this:
trickle :: MonadMoment m => Event [a] -> Event () -> Event a
trickle eadd etick = do
bitems <- accumB [] $ unions -- 1
[ flip (++) <$> eadd -- 2
, drop 1 <$ etick -- 3
]
return $ head <$> filterE (not . null) (bitems <# etick) -- 4
The code works as follows:
The Behavior bitems records the current lists of items.
Items are added when eadd happens, ...
... and one item is removed when etick happens.
The result is an event that happens whenever etick happens, and that contains the first element of the (previously) current list whenever that list is nonempty.
This solution does not seem to require any fancy or intricate reasoning.
Naming the parts:
coords :: Event t [Coord]
ticks :: Event t ()
If we want to remember the most recent Coord until the next firing of ticks, then we necessarily have to be in the some monad Reflex m. This is the monad that allow the transient Event to be persisted.
The core thing you'd like to remember is a stack of Coord. Let's try this:
data Stack a = CS {
cs_lastPop :: Maybe a
, cs_stack :: [a]
} deriving (Show)
stack0 = CS Nothing []
pop :: Stack a -> Stack a
pop (CS _ [] ) = CS Nothing []
pop (CS _ (x:xs)) = CS (Just x) xs
reset :: [a] -> Stack a -> Stack a
reset cs (CS l _) = CS l cs
Nothing reactive there yet, two functions that tweak the Stack Coord in the way you mention in your question.
The reflex code to drive this would build a Dynamic t (Stack Coord), by specifying its initial state and all the things that modify it:
coordStack <- foldDyn ($) stack0 (leftmost [
reset <$> coords
, pop <$ ticks
])
The leftmost here takes a list of Stack Coord -> Stack Coord functions, which are applied in turn to stack0 by foldDyn ($) (as long as coords and ticks never occur in same frame).
Driving all this in main:
main :: IO ()
main = mainWidget $ do
t0 <- liftIO getCurrentTime
-- Some make up 'coords' data, pretending (Coord ~ Char)
coordTimes <- tickLossy 2.5 t0
coords <- zipListWithEvent (\c _ -> c) ["greg","TOAST"] coordTimes
ticks <- tickLossy 1 t0
coordStack <- foldDyn ($) stack0 (leftmost [
reset <$> coords
, pop <$ ticks
])
display coordStack

Haskell: partially drop lazy evaluated results

I have a very large decision tree. It is used as follows:
-- once per application start
t :: Tree
t = buildDecisionTree
-- done several times
makeDecision :: Something -> Decision
makeDecision something = search t something
This decision tree is way too large to fit in memory. But, thanks to lazy evaluation, it is only partially evaluated.
The problem is, that there are scenarios where all possible decisions are tried causing the whole tree to be evaluated. This is not going to terminate, but should not cause a memory overflow either. Further, if this process is aborted, the memory usage does not decrease, as a huge subtree is still evaluated already.
A solution would be to reevaluate the tree every time makeDecision is called, but this would loose the benefits of caching decisions and significantly slow down makeDecision.
I would like to go a middle course. In particular it is very common in my application to do successive decisions with common path prefix in the tree. So I would like to cache the last used path but drop the others, causing them to reevaluate the next time they are used. How can I do this in Haskell?
It is not possible in pure haskell, see question Can a thunk be duplicated to improve memory performance? (as pointed out by #shang). You can, however, do this with IO.
We start with the module heade and list only the type and the functions that should make this module (which will use unsafePerformIO) safe. It is also possible to do this without unsafePerformIO, but that would mean that the user has to keep more of his code in IO.
{-# LANGUAGE ExistentialQuantification #-}
module ReEval (ReEval, newReEval, readReEval, resetReEval) where
import Data.IORef
import System.IO.Unsafe
We start by defining a data type that stores a value in a way that prevents all sharing, by keeping the function and the argument away from each other, and only apply the function when we want the value. Note that the value returned by unsharedValue can be shared, but not with the return value of other invocations (assuming the function is doing something non-trivial):
data Unshared a = forall b. Unshared (b -> a) b
unsharedValue :: Unshared a -> a
unsharedValue (Unshared f x) = f x
Now we define our data type of resettable computations. We need to store the computation and the current value. The latter is stored in an IORef, as we want to be able to reset it.
data ReEval a = ReEval {
calculation :: Unshared a,
currentValue :: IORef a
}
To wrap a value in a ReEval box, we need to have a function and an argument. Why not just a -> ReEval a? Because then there would be no way to prevent the parameter to be shared.
newReEval :: (b -> a) -> b -> ReEval a
newReEval f x = unsafePerformIO $ do
let c = Unshared f x
ref <- newIORef (unsharedValue c)
return $ ReEval c ref
Reading is simple: Just get the value from the IORef. This use of unsafePerformIO is safe becuase we will always get the value of unsharedValue c, although a different “copy” of it.
readReEval :: ReEval a -> a
readReEval r = unsafePerformIO $ readIORef (currentValue r)
And finally the resetting. I left it in the IO monad, not because it would be any less safe than the other function to be wrapped in unsafePerformIO, but because this is the easiest way to give the user control over when the resetting actually happens. You don’t want to risk that all your calls to resetReEval are lazily delayed until your memory has run out or even optimized away because there is no return value to use.
resetReEval :: ReEval a -> IO ()
resetReEval r = writeIORef (currentValue r) (unsharedValue (calculation r))
This is the end of the module. Here is example code:
import Debug.Trace
import ReEval
main = do
let func a = trace ("func " ++ show a) negate a
let l = [ newReEval func n | n <- [1..5] ]
print (map readReEval l)
print (map readReEval l)
mapM_ resetReEval l
print (map readReEval l)
And here you can see that it does what expected:
$ runhaskell test.hs
func 1
func 2
func 3
func 4
func 5
[-1,-2,-3,-4,-5]
[-1,-2,-3,-4,-5]
func 1
func 2
func 3
func 4
func 5
[-1,-2,-3,-4,-5]

Haskell - converting from List to Data.Vector

After profiling my haskell program, I've found that 66% of the time in the program is spent indexing into lists. The solution seems to be using Data.Vector, but I'm having trouble converting: when I change the code to use a Vector it uses tons and tons of memory, and hangs so badly I can't even profile it. What could cause this?
Here is the file I would like to convert: https://github.com/drew-gross/Blokus-AI/blob/master/Grid.hs
and my attempt at converting it: https://github.com/drew-gross/Blokus-AI/blob/convert-to-vector/Grid.hs
Any ideas what I am doing wrong? Or at least, where to look?
makeEmptyGrid width height defaultCell = Grid (Data.Vector.take arraySize $ fromList $ repeat defaultCell) width height
That's a killer right there. fromList converts an entire list to a Vector, but repeat defaultCell is an infinite list.
makeEmptyGrid width height defaultCell = Grid (fromListN arraySize $ repeat defaultCell) width height
or
makeEmptyGrid width height defaultCell = Grid (fromList $ replicate arraySize defaultCell) width height
would fix that.
A cursory look over the rest didn't result in further obvious traps, but I may easily have overlooked some.
This is just an additional thought following upon Daniel. It looked like your Grids were only of Colors It probably won't do much for a small 'Grid' but it is comparatively easy to make an Unbox instance for Color. Then a grid will contain an unboxed array. In Grid.hs you would import Data.Vector.Unboxed rather than Data.Vector. This is in general much better for many reasons, but will require you to put an Unbox a => constraint on many of the definitions. This might have consequences if you want to make or 'map' into Grids full of things of another type than Color, unless it has an Unbox instance.
Below I just add the TH incantation from vector-th-unbox (I just learned about that package recently, and am taking the occasion to test it again) and the two requisite definitions. It wouldn't be much harder to write it by hand following the Bool instance in Data.Vector.Unboxed.Base.
{-#LANGUAGE TemplateHaskell, TypeFamilies, MultiParamTypeClasses#-}
module Color where
import Display
import Data.Vector.Unboxed.Deriving
import qualified Data.Vector.Unboxed as V
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Generic.Mutable as M
import Data.Word (Word8)
data Color = Yellow | Red | Green | Blue | Empty
deriving (Show, Eq, Ord, Enum, Bounded)
fromColor :: Color -> Word8
{-# INLINE fromColor #-}
fromColor = fromIntegral . fromEnum
toColor :: Word8 -> Color
{-# INLINE toColor #-}
toColor x | x < 5 = toEnum (fromIntegral x)
toColor _ = Empty
derivingUnbox "Color"
[t| Color -> Word8 |]
[| fromColor |]
[| toColor |]
-- test
colorCycle :: Int -> V.Vector Color
colorCycle n = V.unfoldr colorop 0 where
colorop m | m < n = Just (toColor (fromIntegral (m `mod` 5)),m+1)
colorop _ = Nothing
-- *Colour> colorCycle 12
-- fromList [Yellow,Red,Green,Blue,Empty,Yellow,
-- Red,Green,Blue,Empty,Yellow,Red]
colorBlack = "\ESC[0;30m"
colorRed = "\ESC[0;31m"
colorGreen = "\ESC[0;32m"
colorYellow = "\ESC[0;33m"
colorBlue = "\ESC[0;34m"
instance Display Color where
display Red = colorRed ++ "R" ++ colorBlack
display Green = colorGreen ++ "G" ++ colorBlack
display Yellow = colorYellow ++ "Y" ++ colorBlack
display Blue = colorBlue ++ "B" ++ colorBlack
display Empty = "."
Edit: In versions of vector-th-unbox preceding 0.1 the following template was used:
derivingUnbox "Color"
[d| instance Unbox' (Color) Word8 |]
[| fromColor |]
[| toColor |]

How does EventM work in Gtk2Hs?

I have a little Haskell program that uses the Gtk2Hs bindings. One can draw points (small squares) on the program's window by clicking on a DrawingArea:
[...]
image <- builderGetObject gui castToDrawingArea "drawingarea"
p <- widgetGetDrawWindow image
gc <- gcNewWithValues p (newGCValues { foreground = Color 0 0 0,
function = Copy })
on image buttonPressEvent (point p gc)
set image [ widgetCanFocus := True ]
[...]
point :: DrawWindow -> GC -> EventM EButton Bool
point p gc = tryEvent $ do
(x', y') <- eventCoordinates
liftIO $ do
let x = round x'
let y = round y'
let relx = x `div` 4
let rely = y `div` 4
gcval <- gcGetValues gc
gcSetValues gc (newGCValues { function = Invert })
drawRectangle p gc True (relx * 4) (rely * 4) 4 4
gcSetValues gc gcval
Through the trial-and-error method and after reading the docs at Hackage, I managed to add a button press event to the drawing area, since the widget doesn't provide a signal for this event by default. However, I don't understand the definition and usage of EventM, so I'm afraid I'll have to struggle with the EventM monad if I must add a new event to a widget again. I must say I'm still not proficient enough in Haskell. I somewhat understand how simple monads work, but this one "type EventM t a = ReaderT (Ptr t) IO a" (defined in Graphics.UI.Gtk.Gdk.EventM) seems a mistery to me.
My question is: Could someone please explain the internals of the EventM monad? For example in the case of "buttonPressEvent :: WidgetClass self => Signal self (EventM EButton Bool)".
I am stacked by the similar problem,seems that EventM is a ReadT which will read the EButton and return Bool.

Output ascii animation from Haskell?

I’m trying to get a very quick and dirty animated display of some data produced using Haskell. The simplest thing to try seems to be ASCII art — in other words, something along the lines of:
type Frame = [[Char]] -- each frame is given as an array of characters
type Animation = [Frame]
display :: Animation -> IO ()
display = ??
How can I best do this?
The part I can’t figure out at all is how to ensure a minimal pause between frames; the rest is straightforward using putStrLn together with clearScreen from the ansi-terminal package, found via this answer.
Well, here's a rough sketch of what I'd do:
import Graphics.UI.SDL.Time (getTicks)
import Control.Concurrent (threadDelay)
type Frame = [[Char]]
type Animation = [Frame]
displayFrame :: Frame -> IO ()
displayFrame = mapM_ putStrLn
timeAction :: IO () -> IO Integer
timeAction act = do t <- getTicks
act
t' <- getTicks
return (fromIntegral $ t' - t)
addDelay :: Integer -> IO () -> IO ()
addDelay hz act = do dt <- timeAction act
let delay = calcDelay dt hz
threadDelay $ fromInteger delay
calcDelay dt hz = max (frame_usec - dt_usec) 0
where frame_usec = 1000000 `div` hz
dt_usec = dt * 1000
runFrames :: Integer -> Animation -> IO ()
runFrames hz frs = mapM_ (addDelay hz . displayFrame) frs
Obviously I'm using SDL here purely for getTicks, because it's what I've used before. Feel free to replace it with any other function to get the current time.
The first argument to runFrames is--as the name suggests--the frame rate in hertz, i.e., frames per second. The runFrames function first converts each frame into an action that draws it, then gives each to the addDelay function, which checks the time before and after running the action, then sleeps until the frame time has passed.
My own code would look a bit different than this, because I'd generally have a more complicated loop that would do other stuff, e.g., polling SDL for events, doing background processing, passing data to the next iteration, &c. But the basic idea is the same.
Obviously the nice thing about this approach is that, while still being fairly simple, you get a consistent frame rate when possible, with a clear means of specifying the target speed.
This builds upon C. A. McCann's anwer, which works nicely but is not time-stable in the long run, in particular when the framerate is not an integer fraction of the tick rate.
import GHC.Word (Word32)
-- import CAMcCann'sAnswer (Frame, Animation, displayFrame, getTicks, threadDelay)
atTick :: IO () -> Word32 -> IO ()
act `atTick` t = do
t' <- getTicks
let delay = max (1000 * (t-t')) 0
threadDelay $ fromIntegral delay
act
runFrames :: Integer -> Animation -> IO ()
runFrames fRate frs = do
t0 <- getTicks
mapM_ (\(t,f) -> displayFrame f `atTick` t) $ timecode fRate32 t0 frs
where timecode ν t0 = zip [ t0 + (1000 * i) `div` ν | i <- [0..] ]
fRate32 = fromIntegral fRate :: Word32

Resources