reactive-banana main loop example

reactive-banana-example.hs

-- |
-- Copyright:  (c) 2018 Ertugrul Söylemez
-- License:    BSD3
-- Maintainer: Ertugrul Söylemez <[email protected]>

{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

import Control.Exception
import Data.Int
import Data.StateVar (($=))
import Foreign.C.Types
import Linear
import Reactive.Banana
import Reactive.Banana.Frameworks
import qualified SDL as Sdl


main :: IO ()
main =
    bracket_ (Sdl.initialize [Sdl.InitVideo]) Sdl.quit $
    bracket (Sdl.createWindow "Example" Sdl.defaultWindow) Sdl.destroyWindow $ \win ->
    bracket (Sdl.createRenderer win (-1) Sdl.defaultRenderer) Sdl.destroyRenderer $ \rend -> do
        (mouseH, fireMouse) <- newAddHandler

        (>>= actuate) . compile $ do
            -- mousePosChanged :: Event (V2 Int32)
            mousePosChanged <- fromAddHandler mouseH

            -- mousePos :: Behavior (V2 Int32)
            -- Initial value (before first occurrence) is (V2 0 0)
            mousePos <- stepper (V2 0 0) mousePosChanged

            -- Size of rectangle to draw, based on horizontal position
            let rectSize :: Behavior Double
                rectSize = (\(V2 x _) -> fromIntegral x / 10) <$> mousePos

            -- posChanged :: Event (Future (V2 Int32, Double))
            posChanged <- changes (liftA2 (,) mousePos rectSize)

            -- What to do when posChanged occurs
            let posChangedReaction :: (V2 Int32, Double) -> IO ()
                posChangedReaction (pos', s') = do
                    let pos :: V2 CInt
                        pos = fmap fromIntegral pos'

                        s = round s'
                        s2 = round (s'/2)
                    Sdl.rendererDrawColor rend $= V4 0 0 0 255
                    Sdl.clear rend
                    Sdl.rendererDrawColor rend $= V4 0 255 0 255
                    Sdl.drawRect rend (Just (Sdl.Rectangle (Sdl.P (pos - V2 s2 s2)) (V2 s s)))
                    Sdl.present rend

            -- rectSizeChangedReaction            :: Double -> IO ()
            -- fmap rectSizeChangedReaction       :: Future Double -> Future (IO ())
            -- (fmap rectSizeChangedReaction <$>) :: Event (Future (Double)) -> Event (Future (IO ()))
            --                                       ^                          ^
            --                  That's rectSizeChanged                          |
            --                                    That's what reactimate' expects
            reactimate' (fmap posChangedReaction <$> posChanged)

        let mainLoop = do
                ev <- Sdl.eventPayload <$> Sdl.waitEvent
                case ev of
                  Sdl.MouseMotionEvent d -> do
                      let Sdl.P pos = Sdl.mouseMotionEventPos d
                      fireMouse pos
                      mainLoop
                  Sdl.QuitEvent -> pure ()
                  _ -> mainLoop

        -- Fire once immediately, because the event resulting from
        -- 'changes' really only occurs on changes, so rectSizeChanged
        -- would trigger only after the pointer has actually been moved.
        fireMouse (V2 0 0)

        mainLoop