Yampa etude

gistfile1.hs

{-# LANGUAGE Arrows #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Main where

import Data.Foldable (Foldable (..))
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Set (Set)
import Data.Set qualified as Set
import FRP.Yampa as Y
import SDL

data ButtonState = Idle | Hovered | Held
  deriving (Show)

data GameInput = GameInput
  { giInputEvents :: [SDL.Event]
  }
data GameOutput = GameOutput
  { goButtonState :: ButtonState
  , goQuitRequested :: Bool
  }
  deriving (Show)

sense :: IORef DTime -> Bool -> IO (DTime, Maybe GameInput)
sense lastTickRef _canBlock = do
  t <- SDL.time
  events <- SDL.pollEvents
  lastTick <- readIORef lastTickRef
  writeIORef lastTickRef t
  let deltaTime = t - lastTick
  case events of
    [] -> pure (deltaTime, Nothing)
    xs -> pure (deltaTime, Just $ GameInput xs)

actuate :: Renderer -> Bool -> GameOutput -> IO Bool
actuate renderer True GameOutput {..} = do
  SDL.rendererDrawColor renderer $= SDL.V4 0 0 255 255
  SDL.clear renderer
  SDL.rendererDrawColor renderer
    $= case goButtonState of
      Idle -> SDL.V4 25 25 25 255
      Hovered -> SDL.V4 100 25 25 255
      Held -> SDL.V4 255 25 25 255
  SDL.fillRect renderer . Just . SDL.Rectangle (SDL.P $ SDL.V2 250 250) $
    SDL.V2 250 250
  SDL.present renderer
  pure goQuitRequested
actuate _ _ _ = pure False

initGame :: IO GameInput
initGame = do
  events <- SDL.pollEvents
  pure $ GameInput events

keysDown :: SF GameInput (Set SDL.Keycode)
keysDown = arr $ foldr' (\x y -> mapInputDown x <> y) mempty . giInputEvents
  where
    mapInputDown (SDL.Event _ (SDL.KeyboardEvent ev))
      | keyboardEventKeyMotion ev == Pressed =
          Set.singleton . keysymKeycode $ keyboardEventKeysym ev
    mapInputDown _ = mempty

keyDown :: SDL.Keycode -> SF GameInput (Y.Event ())
keyDown key = edge <<< Set.member key ^<< keysDown

mousePosition :: SF GameInput (V2 Float)
mousePosition = hold (V2 0 0) <<^ foldr' updateOnMouseEvent NoEvent . giInputEvents
  where
    updateOnMouseEvent (SDL.Event _ (SDL.MouseMotionEvent ev)) _ =
      let P pos = SDL.mouseMotionEventPos ev
       in Y.Event (fromIntegral <$> pos)
    updateOnMouseEvent _ yEv = yEv

mouseButtonDown :: SDL.MouseButton -> SF GameInput (Y.Event ())
mouseButtonDown button = arr $ mergeEvents . fmap toEvent . giInputEvents
  where
    toEvent (SDL.Event _ (SDL.MouseButtonEvent ev))
      | mouseButtonEventMotion ev == Pressed && mouseButtonEventButton ev == button =
          Y.Event ()
    toEvent _ = NoEvent

mouseButtonUp :: SDL.MouseButton -> SF GameInput (Y.Event ())
mouseButtonUp button = arr $ mergeEvents . fmap toEvent . giInputEvents
  where
    toEvent (SDL.Event _ (SDL.MouseButtonEvent ev))
      | mouseButtonEventMotion ev == Released && mouseButtonEventButton ev == button =
          Y.Event ()
    toEvent _ = NoEvent

data Rect = Rect (V2 Float) (V2 Float)

pointInRect :: V2 Float -> Rect -> Bool
pointInRect (V2 x y) (Rect (V2 rx ry) (V2 w h)) =
  between x rx (rx + w) && between y ry (ry + h)
  where
    between v l r = v >= l && v <= r

data UILayout
  = Button Rect

mouseLeftRect :: Rect -> SF (V2 Float) (Y.Event ())
mouseLeftRect rect = edge <<^ not . (`pointInRect` rect)

buttonHeld :: UILayout -> SF GameInput ButtonState
buttonHeld b@(Button rect) = proc gi -> do
  mousePos <- mousePosition -< gi
  buttonUp <- mouseButtonUp ButtonLeft -< gi
  let switchEvent = buttonUp `tag` pointInRect mousePos rect
  buttonState <- switch (first $ constant Held) (\x -> fst ^>> nextState x b) -< (gi, switchEvent)
  returnA -< buttonState
  where
    nextState True = buttonHovered
    nextState False = buttonIdle

buttonHovered :: UILayout -> SF GameInput ButtonState
buttonHovered b@(Button rect) = proc gi -> do
  mousePos <- mousePosition -< gi
  mouseLeft <- mouseLeftRect rect -< mousePos
  buttonDown <- mouseButtonDown ButtonLeft -< gi
  let
    switchEvent = tagWith True mouseLeft `lMerge` tagWith False buttonDown
  buttonState <-
    switch (first $ constant Hovered) (\x -> fst ^>> nextState x b)
      -<
        (gi, switchEvent)
  returnA -< buttonState
  where
    nextState True = buttonIdle
    nextState False = buttonHeld

buttonIdle :: UILayout -> SF GameInput ButtonState
buttonIdle b@(Button rect) = proc gi -> do
  mousePos <- mousePosition -< gi
  mouseEnteredRect <- edge <<^ (`pointInRect` rect) -< mousePos
  buttonState <-
    switch (first $ constant Idle) (const $ fst ^>> buttonHovered b)
      -<
        (gi, mouseEnteredRect)
  returnA -< buttonState

process :: UILayout -> SF GameInput GameOutput
process uiLayout = proc gi -> do
  goButtonState <- buttonIdle uiLayout -< gi
  quitPressed <- keyDown KeycodeEscape -< gi
  let
    goQuitRequested = isEvent quitPressed
  returnA -< GameOutput {..}

gameUI :: UILayout
gameUI = Button $ Rect (V2 250 250) (V2 250 250)

main :: IO ()
main = do
  SDL.initializeAll
  window <- SDL.createWindow "button example" SDL.defaultWindow
  renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer
  dTimeRef <- newIORef 0
  reactimate initGame (sense dTimeRef) (actuate renderer) (process gameUI)
  destroyWindow window