Simpler alternative libs to Reactive? (Haskell) - haskell

Question

I'm learning Haskell, and trying to write some event-driven programs.
The following code is from the tutorial: http://www.haskell.org/haskellwiki/OpenGLTutorial2
main = do
(progname,_) <- getArgsAndInitialize
initialDisplayMode $= [DoubleBuffered]
createWindow "Hello World"
reshapeCallback $= Just reshape
angle <- newIORef (0.0::GLfloat) -- 1
delta <- newIORef (0.1::GLfloat) -- 2
position <- newIORef (0.0::GLfloat, 0.0) -- 3
keyboardMouseCallback $= Just (keyboardMouse delta position)
idleCallback $= Just (idle angle delta)
displayCallback $= (display angle position)
mainLoop
The states are stored in IORefs, which makes it looks just like imperative language.
I'v heard that there are APIs other than this Graphics.UI.GLUT, (e.g. Reactive), but it looks very complicated.
My approach is that the lib provide a function runEventHandler, and the user writes a handler that accepts list of Events and convert them to IO ().
handler :: [Event] -> IO ()
runEventHandler :: ( [Event] -> IO () ) -> IO ()
And the main function should look like:
main = runEventHandler handler
Is there such libs?
I am currently implementing one using multi-threading, but I'm worrying that it might be poor in performance ...

Answer 1

reactive-banana is a mature library very similar to reactive. We won't try to reinvent an frp library; instead we'll explore how to integrate reactive-banana into a project for ourselves.
The big picture
To use a functional reactive programming library like reactive-banana with OpenGL we will divide the work into 4 parts, 2 of which already exist. We will use the existing GLUT library to interact with OpenGL, and the existing reactive-banana library for an implementation of functional reactive programming. We will provide 2 parts of our own. The first part we will provide is a framework that will connect GLUT to reactive-banana. The second part we will provide is the program that will be written in terms of the frp implementation (reactive-banana) and framework and GLUT types.
Both of the parts that we provide will be written in terms of the reactive-banana frp library. The library has two big ideas, Event t a and Behavior t a. Event t a represents events carrying data of type a that occur at different points in time. Behavior t a represents a time varying value of type a that is defined at all points in time. The t type argument we are required by the type system to preserve but otherwise ignore.
Most of the interface to Event and Behavior are hidden in their instances. Event is a Functor - we can fmap or <$> a function over the values of any Event.
fmap :: (a -> b) -> Event t a -> Event t b
Behavior is both Applicative and a Functor. We can fmap or <$> a function over all the values a Behavior takes on, can provide new constant unchanging values with pure, and calculate new Behaviors with <*>.
fmap :: (a -> b) -> Behavior t a -> Behavior t b
pure :: a -> Behavior t a
<*> :: Behavior t (a -> b) -> Behavior t a -> Behavior t b
There are a few other functions provided by reactive-banana that provide functionality that can't be represented in terms of base typeclasses. These introduce statefulness, combine Events together, and convert between Events and Behaviors.
State is introduced by accumE which takes an initial value and an Event of changes from the previous value to a new value and produces an Event of the new values. accumB produces a Behavior instead
accumE :: a -> Event t (a -> a) -> Event t a
accumB :: a -> Event t (a -> a) -> Behavior t a
union combines two event streams together
union :: Event t a -> Event t a -> Event t a
stepper can convert an Event to a Behavior holding the most recent value if we provide an initial value so that it is defined at all points in time. apply or <#> can convert a Behavior into an Event if we provide a series of Events at which to poll the current value of the Behavior.
stepper :: a -> Event t a -> Behavior t a
<#> :: Behavior t (a -> b) -> Event t a -> Event t b
The instances for Event and Behavior and the 19 functions in Reactive.Banana.Combinators make up the entire interface for functional reactive programming.
Overall, we will need the GLUT library and libraries used by the OpenGL example we are implementing, the reactive-banana library, the reactive-banana exports for making frameworks and the RankNTypes extension, a couple mechanisms for interthread communication, and the ability to read the system clock.
{-# LANGUAGE RankNTypes #-}
import Graphics.UI.GLUT
import Control.Monad
import Reactive.Banana
import Reactive.Banana.Frameworks
import Data.IORef
import Control.Concurrent.MVar
import Data.Time
The framework interface
Our framework will map the IO events from GLUT to reactive-banana Events and Behaviors. There are four GLUT events that the example uses - reshapeCallback, keyboardMouseCallback, idleCallback, and displayCallback. We will map these to Events and Behaviors.
reshapeCallback is run when the user resizes the window. As a callback, it required something of the type type ReshapeCallback = Size -> IO (). We will represent this as an Event t Size.
keyboardMouseCallback is run when the user provides keyboard input, moves the mouse, or clicks a mouse button. As a callback, it required something of the type type KeyboardMouseCallback = Key -> KeyState -> Modifiers -> Position -> IO (). We will represent this as an input with type Event t KeyboardMouse, where KeyboardMouse bundles together all of the arguments passed to the callback.
data KeyboardMouse = KeyboardMouse {
key :: Key,
keyState :: KeyState,
modifiers :: Modifiers,
pos :: Position
}
idleCallback is run when time passes. We will represent this as a behavior that tracks the amount of time that has passed, Behavior t DiffTime. Because it is a Behavior instead of an Event, our program won't be able to directly observe time passing. If this isn't desired, we could use an Event instead.
Bundling all of the inputs together we get
data Inputs t = Inputs {
keyboardMouse :: Event t KeyboardMouse,
time :: Behavior t DiffTime,
reshape :: Event t Size
}
displayCallback is different from the other callbacks; it isn't for the input to the program, but instead is for outputting what needs to be displayed. Since GLUT could run this at any time to try to display something on the screen, it makes sense for it to be defined at all points in time. We will represent this output with a Behavior t DisplayCallback.
There is one more output we will need - in response to events the example program occasionally produces other IO actions. We will allow the program to raise events to execute arbitrary IO with an Event t (IO ()).
Bundling both outputs together we get
data Outputs t = Outputs {
display :: Behavior t DisplayCallback,
whenIdle :: Event t (IO ())
}
Our framework will be invoked by passing it a program with the type forall t. Inputs t -> Outputs t. We will define program and reactiveGLUT in the next two sections.
main :: IO ()
main = do
(progname,_) <- getArgsAndInitialize
initialDisplayMode $= [DoubleBuffered]
createWindow "Hello World"
reactiveGLUT program
The program
The program will use reactive-banana to map the Inputs to the Outputs. To get started porting the tutorial code, we'll remove the IORefs from cubes and rename reshape to onReshape since it conflicts with a name from our framework interface.
cubes :: GLfloat -> (GLfloat, GLfloat) -> DisplayCallback
cubes a (x',y') = do
clear [ColorBuffer]
loadIdentity
translate $ Vector3 x' y' 0
preservingMatrix $ do
rotate a $ Vector3 0 0 1
scale 0.7 0.7 (0.7::GLfloat)
forM_ (points 7) $ \(x,y,z) -> preservingMatrix $ do
color $ Color3 ((x+1)/2) ((y+1)/2) ((z+1)/2)
translate $ Vector3 x y z
cube 0.1
swapBuffers
onReshape :: ReshapeCallback
onReshape size = do
viewport $= (Position 0 0, size)
keyboardMouse will be completely replaced by positionChange and angleSpeedChange. These convert a KeyboardMouse event into a change to make to either the position or the speed the cubes are rotating. When no change is needed for an event, they return Nothing.
positionChange :: Fractional a => KeyboardMouse -> Maybe ((a, a) -> (a, a))
positionChange (KeyboardMouse (SpecialKey k) Down _ _) = case k of
KeyLeft -> Just $ \(x,y) -> (x-0.1,y)
KeyRight -> Just $ \(x,y) -> (x+0.1,y)
KeyUp -> Just $ \(x,y) -> (x,y+0.1)
KeyDown -> Just $ \(x,y) -> (x,y-0.1)
_ -> Nothing
positionChange _ = Nothing
angleSpeedChange :: Num a => KeyboardMouse -> Maybe (a -> a)
angleSpeedChange (KeyboardMouse (Char c) Down _ _) = case c of
' ' -> Just negate
'+' -> Just (+1)
'-' -> Just (subtract 1)
_ -> Nothing
angleSpeedChange _ = Nothing
Calculating the position is fairly easy, we accumulate the changes from the keyboard inputs. filterJust :: Event t (Maybe a) -> Event t a throws out the events that we weren't interested in.
positionB :: Fractional a => Inputs t -> Behavior t (a, a)
positionB = accumB (0.0, 0.0) . filterJust . fmap positionChange . keyboardMouse
We'll calculate the angle of the rotating cubes a bit differently. We'll remember the time and angle when the speed changes, apply a function that calculates the difference in angle to the difference in times, and add that to the initial angle.
angleCalculation :: (Num a, Num b) => a -> b -> (a -> b) -> a -> b
angleCalculation a0 b0 f a1 = f (a1 - a0) + b0
Calculating the angle is a bit more difficult. First we compute an event, angleF :: Event t (DiffTime -> GLfloat), holding a function from a difference between times to a difference between angles. We lift and apply our angleCalculation to the current time and angle, and poll that at each occurrence of the angleF event. We convert the polled function into a Behavior with stepper and apply it to the current time.
angleB :: Fractional a => Inputs t -> Behavior t a
angleB inputs = angle
where
initialSpeed = 2
angleSpeed = accumE initialSpeed . filterJust . fmap angleSpeedChange . keyboardMouse $ inputs
scaleSpeed x y = 10 * x * realToFrac y
angleF = scaleSpeed <$> angleSpeed
angleSteps = (angleCalculation <$> time inputs <*> angle) <#> angleF
angle = stepper (scaleSpeed initialSpeed) angleSteps <*> time inputs
The whole program maps Inputs to Outputs. It says that the behavior for what to display is cubes lifted and applied to the angle and position. The Event for other IO side effects is onReshape every time the reshape event happens.
program :: Inputs t -> Outputs t
program inputs = outputs
where
outputs = Outputs {
display = cubes <$> angleB inputs <*> positionB inputs,
whenIdle = onReshape <$> reshape inputs
}
The framework
Our framework accepts a program with the type forall t. Inputs t -> Outputs t and runs it. To implement the framework, we use the functions in Reactive.Banana.Frameworks. These functions allow us to raise Events from IO and run IO actions in response to Events. We can make Behaviors from Events and poll Behaviors when Events occur using the functions from Reactive.Banana.Combinators.
reactiveGLUT :: (forall t. Inputs t -> Outputs t) -> IO ()
reactiveGLUT program = do
-- Initial values
initialTime <- getCurrentTime
-- Events
(addKeyboardMouse, raiseKeyboardMouse) <- newAddHandler
(addTime, raiseTime) <- newAddHandler
(addReshape, raiseReshape) <- newAddHandler
(addDisplay, raiseDisplay) <- newAddHandler
newAddHandler creates a handle with which to talk about an Event t a, and a function to raise the event of type a -> IO (). We make the obvious events for keyboard and mouse input, idle time passing, and the window shape changing. We also make an event that we will use to poll the display Behavior when we need to run it in the displayCallback.
We have one tricky problem to overcome - OpenGL requires all the UI interaction to happen in a specific thread, but we aren't sure what thread the actions we bind to reactive-banana events will happen in. We'll use a couple of variables shared across threads to make sure the Output IO is run in the OpenGL thread. For display output, we'll use an MVar to store the polled display action. For IO actions that are queued in whenIdle we'll accumulate them in an IORef,
-- output variables and how to write to them
displayVar <- newEmptyMVar
whenIdleRef <- newIORef (return ())
let
setDisplay = putMVar displayVar
runDisplay = takeMVar displayVar >>= id
addWhenIdle y = atomicModifyIORef' whenIdleRef (\x -> (x >> y, ()))
runWhenIdle = atomicModifyIORef' whenIdleRef (\x -> (return (), x)) >>= id
Our whole network consists of the following parts. First we create Events (using fromAddHandler) or Behaviors (using fromChanges) for each of the Inputs and an Event for polling the output display. We perform a small amount of processing to simplify the clock. We apply the program to the inputs we prepared to get the program's Outputs. Using <#, we poll the display whenever our display event happens. Finally, reactimate tells reactive-banana to run setDisplay or addWhenIdle whenever the corresponsonding Event occurs. Once we have described the network we compile and actuate it.
-- Reactive network for GLUT programs
let networkDescription :: forall t. Frameworks t => Moment t ()
networkDescription = do
keyboardMouseEvent <- fromAddHandler addKeyboardMouse
clock <- fromChanges initialTime addTime
reshapeEvent <- fromAddHandler addReshape
displayEvent <- fromAddHandler addDisplay
let
diffTime = realToFrac . (flip diffUTCTime) initialTime <$> clock
inputs = Inputs keyboardMouseEvent diffTime reshapeEvent
outputs = program inputs
displayPoll = display outputs <# displayEvent
reactimate $ fmap setDisplay displayPoll
reactimate $ fmap addWhenIdle (whenIdle outputs)
network <- compile networkDescription
actuate network
For each of the GLUT callbacks we are interested in we raise the corresponding reactive-banana Event. For the idle callback we also run any queued events. For the display callback, we run the polled DisplayCallback.
-- Handle GLUT events
keyboardMouseCallback $= Just (\k ks m p -> raiseKeyboardMouse (KeyboardMouse k ks m p))
idleCallback $= Just (do
getCurrentTime >>= raiseTime
runWhenIdle
postRedisplay Nothing)
reshapeCallback $= Just raiseReshape
displayCallback $= do
raiseDisplay ()
runDisplay
mainLoop
The rest of the example
The rest of the tutorial code can be repeated verbatim
vertex3f :: (GLfloat, GLfloat, GLfloat) -> IO ()
vertex3f (x, y, z) = vertex $ Vertex3 x y z
points :: Int -> [(GLfloat,GLfloat,GLfloat)]
points n = [ (sin (2*pi*k/n'), cos (2*pi*k/n'), 0) | k <- [1..n'] ]
where n' = fromIntegral n
cube :: GLfloat -> IO ()
cube w = renderPrimitive Quads $ mapM_ vertex3f
[ ( w, w, w), ( w, w,-w), ( w,-w,-w), ( w,-w, w),
( w, w, w), ( w, w,-w), (-w, w,-w), (-w, w, w),
( w, w, w), ( w,-w, w), (-w,-w, w), (-w, w, w),
(-w, w, w), (-w, w,-w), (-w,-w,-w), (-w,-w, w),
( w,-w, w), ( w,-w,-w), (-w,-w,-w), (-w,-w, w),
( w, w,-w), ( w,-w,-w), (-w,-w,-w), (-w, w,-w) ]