reactive-banana是一个成熟的库，与reactive非常相似。我们不会尝试重新发明一个 frp 库；相反，我们将探索如何将响应式香蕉集成到我们自己的项目中。
大图
为了在 OpenGL 中使用像响应式香蕉这样的函数式响应式编程库，我们将工作分为 4 部分，其中 2 部分已经存在。我们将使用现有的 GLUT 库与 OpenGL 进行交互，并使用现有的响应式香蕉库来实现函数式响应式编程。我们将提供我们自己的 2 个部分。我们将提供的第一部分是将 GLUT 连接到响应式香蕉的框架。我们将提供的第二部分是根据 frp 实现（reactive-banana）和框架和 GLUT 类型编写的程序。
我们提供的两个部分都将根据 reactive-banana frp 库编写。图书馆有两个大想法，Event t a和Behavior t a. Event t a表示携带a在不同时间点发生的类型数据的事件。表示在所有时间点定义Behavior t a的类型的时变值. 类型系统要求我们保留但忽略a的类型参数。t
大多数接口Event都Behavior隐藏在它们的实例中。Event是一个Functor- 我们可以fmap或<$>任何值的函数Event。
fmap :: (a -> b) -> Event t a -> Event t b
Behavior既是Applicative又是Functor。我们可以对 a 的所有值fmap或<$>一个函数Behavior，可以用 提供新的不变的值pure，并用 计算新Behavior的 s <*>。
fmap :: (a -> b) -> Behavior t a -> Behavior t b
pure :: a -> Behavior t a
<*> :: Behavior t (a -> b) -> Behavior t a -> Behavior t b
reactive-banana 还提供了一些其他功能，这些功能提供了无法用基本类型类表示的功能。这些引入了有状态，将Events 组合在一起，并在Events 和Behaviors 之间进行转换。
状态被引入，accumE它接受一个初始值和一个Event从先前值到新值的变化，并产生一个Event新值。而是accumB产生一个Behavior
accumE :: a -> Event t (a -> a) -> Event t a
accumB :: a -> Event t (a -> a) -> Behavior t a
union将两个事件流组合在一起
union :: Event t a -> Event t a -> Event t a
stepper如果我们提供一个初始值，以便在所有时间点都定义它，则可以将 an 转换Event为Behavior持有最新值。apply或者，如果我们提供<@>一系列轮询.BehaviorEventEventsBehavior
stepper :: a -> Event t a -> Behavior t a
<@> :: Behavior t (a -> b) -> Event t a -> Event t b
Reactive.Banana.CombinatorsEvent中的andBehavior和 19 个函数的实例构成了函数式响应式编程的整个接口。
总的来说，我们将需要 GLUT 库和我们正在实现的 OpenGL 示例所使用的库、reactive-banana 库、用于制作框架的 reactive-banana 导出和 RankNTypes 扩展、一些用于线程间通信的机制以及读取能力系统时钟。
{-# 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
框架接口
我们的框架会将IO事件从 GLUT 映射到 reactive-bananaEvent和Behaviors。该示例使用了四个 GLUT 事件 - reshapeCallback、keyboardMouseCallback、idleCallback和displayCallback。我们将这些映射到Events 和Behaviors。
reshapeCallback当用户调整窗口大小时运行。作为回调，它需要 type 的东西type ReshapeCallback = Size -> IO ()。我们将其表示为Event t Size.
keyboardMouseCallback当用户提供键盘输入、移动鼠标或单击鼠标按钮时运行。作为回调，它需要 type 的东西type KeyboardMouseCallback = Key -> KeyState -> Modifiers -> Position -> IO ()。我们将其表示为 type 的输入Event t KeyboardMouse，其中KeyboardMouse将传递给回调的所有参数捆绑在一起。
data KeyboardMouse = KeyboardMouse {
key :: Key,
keyState :: KeyState,
modifiers :: Modifiers,
pos :: Position
}
idleCallback时间流逝时运行。我们将把它表示为一种跟踪已经过去的时间量的行为，Behavior t DiffTime。因为它是 aBehavior而不是 a Event，所以我们的程序将无法直接观察到时间的流逝。如果这不是我们所希望的，我们可以使用 anEvent来代替。
将所有输入捆绑在一起，我们得到
data Inputs t = Inputs {
keyboardMouse :: Event t KeyboardMouse,
time :: Behavior t DiffTime,
reshape :: Event t Size
}
displayCallback与其他回调不同；它不是用于程序的输入，而是用于输出需要显示的内容。由于 GLUT 可以随时运行它以尝试在屏幕上显示某些内容，因此在所有时间点定义它是有意义的。我们将用 表示这个输出Behavior t DisplayCallback。
我们还需要一个输出 - 为了响应事件，示例程序偶尔会产生其他 IO 操作。我们将允许程序引发事件以使用Event t (IO ()).
将两个输出捆绑在一起，我们得到
data Outputs t = Outputs {
display :: Behavior t DisplayCallback,
whenIdle :: Event t (IO ())
}
我们的框架将通过传递一个类型为 的程序来调用forall t. Inputs t -> Outputs t。我们将在接下来的两节中定义program和。reactiveGLUT
main :: IO ()
main = do
(progname,_) <- getArgsAndInitialize
initialDisplayMode $= [DoubleBuffered]
createWindow "Hello World"
reactiveGLUT program
该程序
该程序将使用 reactive-banana 将 映射Inputs到Outputs. 为了开始移植教程代码，我们将从中删除IORefscubes并重命名reshape为，onReshape因为它与我们框架接口中的名称冲突。
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将被positionChange和完全取代angleSpeedChange。这些将KeyboardMouse事件转换为对立方体旋转的位置或速度进行的更改。当事件不需要更改时，它们会返回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
计算位置相当容易，我们累积键盘输入的变化。filterJust :: Event t (Maybe a) -> Event t a抛出我们不感兴趣的事件。
positionB :: Fractional a => Inputs t -> Behavior t (a, a)
positionB = accumB (0.0, 0.0) . filterJust . fmap positionChange . keyboardMouse
我们将稍微不同地计算旋转立方体的角度。我们将记住速度变化时的时间和角度，将计算角度差的函数应用于时间差，并将其添加到初始角度。
angleCalculation :: (Num a, Num b) => a -> b -> (a -> b) -> a -> b
angleCalculation a0 b0 f a1 = f (a1 - a0) + b0
计算angle起来有点困难。首先我们计算一个事件 ，它angleF :: Event t (DiffTime -> GLfloat)持有一个从时间差到角度差的函数。我们将我们提升并应用angleCalculation到当前的timeandangle中，并在每次事件发生时对其进行轮询angleF。我们将轮询函数转换为Behaviorwithstepper并将其应用于 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
整个program映射Inputs到Outputs. 它表示要提升什么的行为display并将cubes其应用于角度和位置。其他副作用是Event每次事件发生时。IOonReshapereshape
program :: Inputs t -> Outputs t
program inputs = outputs
where
outputs = Outputs {
display = cubes <$> angleB inputs <*> positionB inputs,
whenIdle = onReshape <$> reshape inputs
}
框架
我们的框架接受具有该类型的程序forall t. Inputs t -> Outputs t并运行它。为了实现该框架，我们使用Reactive.Banana.Frameworks. 这些函数允许我们从 s 中引发EventsIO并运行IO响应Events 的操作。当s 出现时，我们可以使用函数 from 生成BehaviorsEvent和 poll s 。BehaviorEventReactive.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创建一个用于讨论 的句柄Event t a，以及一个引发类型事件的函数a -> IO ()。我们为键盘和鼠标输入、空闲时间的流逝和窗口形状的变化制作了明显的事件。我们还创建了一个事件，display Behavior当我们需要在displayCallback.
我们有一个棘手的问题需要克服 - OpenGL 要求所有 UI 交互都发生在一个特定的线程中，但是我们不确定我们绑定到响应式香蕉事件的动作会发生在哪个线程中。我们将使用几个变量跨线程共享以确保Output IO在 OpenGL 线程中运行。对于display输出，我们将使用 anMVar来存储轮询display操作。对于IO排队的操作，whenIdle我们会将它们累积在一个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
我们的整个网络由以下部分组成。首先，我们为每个 the和 an创建Events (using fromAddHandler) 或Behaviors (using )来轮询 output 。我们执行少量处理以简化时钟。我们将 应用到我们准备获取程序的. 使用，我们在显示事件发生时轮询。最后，告诉 reactive-banana 运行或无论何时发生相应的事件。一旦我们描述了我们和它的网络。fromChangesInputsEventdisplayprograminputsOutputs<@displayreactimatesetDisplayaddWhenIdleEventcompileactuate
-- 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
对于我们感兴趣的每个 GLUT 回调，我们都会提出相应的 reactive-banana Event。对于空闲回调，我们还运行任何排队的事件。对于显示回调，我们运行 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
示例的其余部分
教程代码的其余部分可以逐字重复
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) ]