更简单的替代库到Reactive？(Haskell的)

Question

我正在学习Haskell,并尝试编写一些事件驱动的程序.

以下代码来自教程: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

状态存储在IORefs中,这使得它看起来就像命令式语言.

我听说除了这个之外还有其他API Graphics.UI.GLUT,(例如Reactive),但它看起来非常复杂.

我的方法是lib提供一个函数runEventHandler,用户编写一个handler接受Events 列表并将其转换为IO ().

handler :: [Event] -> IO ()
runEventHandler :: ( [Event] -> IO () ) -> IO ()

而main功能应该是这样的:

main = runEventHandler handler

有这样的库吗？

我目前正在使用多线程实现一个,但我担心它的性能可能会很差......

Answer 1

反应性香蕉是一种非常类似于反应性的成熟库.我们不会尝试重新发明一个frp库; 相反,我们将探索如何将反应性香蕉整合到我们自己的项目中.

大局

要使用功能性反应式编程库,如反应性香蕉和OpenGL,我们将工作分为4个部分,其中2个已经存在.我们将使用现有的GLUT库与OpenGL进行交互,并使用现有的reactive-banana库来实现功能性反应式编程.我们将提供我们自己的两个部分.我们将提供的第一部分是将GLUT连接到反应性香蕉的框架.我们将提供的第二部分是将根据frp实现(reactive-banana)和框架以及GLUT类型编写的程序.

我们提供的两个部分都将根据反应性香蕉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.我们可以fmap或者<$>对所有值进行Behavior处理,可以提供新的常量不变值pure,并计算新的Behaviors <*>.

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如果我们提供初始值,则可以将Eventa 转换为Behavior保持最新值,以便在所有时间点定义它.apply或者<@>可以将a转换Behavior成Event如果我们提供一系列的Events轮询当前值的Behavior.

stepper :: a -> Event t a -> Behavior t a
<@> :: Behavior t (a -> b) -> Event t a -> Event t b

Reactive.Banana.Combinators中的Event和/ Behavior和19个函数的实例构成了功能反应式编程的整个接口.

总的来说,我们需要我们正在实现的OpenGL示例使用的GLUT库和库,反应香蕉库,用于制作框架的反应性香蕉出口和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 映射到反应性香蕉Event和Behaviors.有迹象表明,例如使用四个GLUT事件- ,reshapeCallback,keyboardMouseCallback,idleCallback和displayCallback.我们将这些映射到Events和Behaviors.

reshapeCallback在用户调整窗口大小时运行.作为回调,它需要某种类型的东西type ReshapeCallback = Size -> IO ().我们将此表示为Event t Size.

keyboardMouseCallback当用户提供键盘输入,移动鼠标或单击鼠标按钮时运行.作为回调,它需要某种类型的东西type KeyboardMouseCallback = Key -> KeyState -> Modifiers -> Position -> IO ().我们将此表示为带有类型的输入Event t KeyboardMouse,其中KeyboardMouse将所有传递给回调的参数捆绑在一起.

data KeyboardMouse = KeyboardMouse {
    key :: Key,
    keyState :: KeyState,
    modifiers :: Modifiers,
    pos :: Position
}

idleCallback在时间流逝时运行.我们将此表示为跟踪已经过去的时间量的行为Behavior t DiffTime.因为它是一个Behavior而不是一个Event,我们的程序将无法直接观察时间的流逝.如果不希望这样,我们可以Event改为使用.

将所有输入捆绑在一起我们得到

data Inputs t = Inputs {
    keyboardMouse :: Event t KeyboardMouse,    
    time :: Behavior t DiffTime,
    reshape :: Event t Size
}

displayCallback与其他回调不同; 它不是用于程序的输入,而是用于输出需要显示的内容.由于GLUT可以在任何时候运行它以尝试在屏幕上显示某些内容,因此在所有时间点定义它是有意义的.我们将使用a表示此输出Behavior t DisplayCallback.

我们还需要一个输出 - 响应事件,示例程序偶尔会产生其他IO操作.我们将允许程序引发事件以执行任意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

该程序

该程序将使用反应香蕉来映射Inputs到Outputs.为了开始移植教程代码,我们将删除IORefs cubes并重命名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的当前time和angle,并在每次事件发生时进行轮询angleF.我们将轮询函数转换为Behaviorwith stepper并将其应用于当前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其他IO的副作用是onReshape每个时间reshape事件发生.

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.这些函数允许我们Event从s中提取s IO并执行IO操作以响应Events.我们可以使用Behaviors中的函数从Events和pol进行Behaviors .EventReactive.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交互都发生在特定的线程中,但是我们不确定我们绑定到reactive-banana事件的动作会发生在什么线程中.我们将使用几个变量跨线程共享以确保Output IO在OpenGL线程中运行.对于display输出,我们将使用a MVar来存储轮询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

我们的整个网络由以下部分组成.首先,我们为每个创建Events(使用fromAddHandler)或Behaviors(使用fromChanges),Inputs并且Event用于轮询输出display.我们执行少量处理以简化时钟.我们应用program到inputs我们准备让程序的Outputs.使用<@,我们display在显示事件发生时轮询.最后,reactimate告诉反应香蕉运行setDisplay或addWhenIdle何时Event发生相应的反应.一旦我们描述了网络我们compile和actuate它.

    -- 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回调,我们引发相应的反应性香蕉Event.对于空闲回调,我们还运行任何排队事件.对于显示回调,我们运行轮询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) ]