vulkan-tutorial/extern/affection/examples/example00/Main.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

module Main where

import Affection as A

import Control.Concurrent.STM
import Control.Concurrent.MVar
import Control.Monad

import qualified SDL

import Data.Maybe (isJust, fromJust)
import Data.String

data StateData = StateData
  { sdSubs :: Subsystems
  , sdJoys :: MVar [SDL.Joystick]
  , doNextStep :: MVar Bool
  }

instance Affectionate StateData where
  loadState = load
  preLoop = pre
  handleEvents = handle
  update = Main.update
  draw = Main.draw
  cleanUp = clean
  hasNextStep = liftIO . readMVar . doNextStep

data Subsystems = Subsystems
  { subWindow   :: Main.Window
  , subMouse    :: Main.Mouse
  , subKeyboard :: Main.Keyboard
  , subJoystick :: Main.Joystick
  }

newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection ())])

instance Participant Main.Window where
  type Mesg Main.Window = WindowMessage

  partSubscribers (Window t) = generalSubscribers t

  partSubscribe (Window t) = generalSubscribe t

  partUnSubscribe (Window t) = generalUnSubscribe t

instance SDLSubsystem Main.Window where
  consumeSDLEvents = consumeSDLWindowEvents

instance Participant Mouse where
  type Mesg Mouse = MouseMessage

  partSubscribers (Mouse t) = generalSubscribers t

  partSubscribe (Mouse t) = generalSubscribe t

  partUnSubscribe (Mouse t) = generalUnSubscribe t

instance SDLSubsystem Mouse where
  consumeSDLEvents = consumeSDLMouseEvents

instance Participant Keyboard where
  type Mesg Keyboard = KeyboardMessage

  partSubscribers (Keyboard t) = generalSubscribers t

  partSubscribe (Keyboard t) = generalSubscribe t

  partUnSubscribe (Keyboard t) = generalUnSubscribe t

instance SDLSubsystem Keyboard where
  consumeSDLEvents = consumeSDLKeyboardEvents

instance Participant Joystick where
  type Mesg Joystick = JoystickMessage

  partSubscribers (Joystick t) = generalSubscribers t

  partSubscribe (Joystick t) = generalSubscribe t

  partUnSubscribe (Joystick t) = generalUnSubscribe t

instance SDLSubsystem Joystick where
  consumeSDLEvents = consumeSDLJoystickEvents

main :: IO ()
main = do
  logIO Debug "Starting"
  let conf = AffectionConfig
        { initComponents = All
        , windowTitle = "affection: example00"
        , windowConfigs =
          [
          ( 0
          , SDL.defaultWindow
            { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
              { SDL.glProfile = SDL.Core SDL.Normal 3 3
              }
            }
          , SDL.Windowed
          )
          ]
        } :: AffectionConfig StateData
  withAffection conf

load :: IO StateData
load =
  StateData <$> (Subsystems
    <$> (Window <$> newTVarIO [])
    <*> (Mouse <$> newTVarIO [])
    <*> (Keyboard <$> newTVarIO [])
    <*> (Joystick <$> newTVarIO [])
    )
    <*> newMVar []
    <*> newMVar True

pre :: StateData -> Affection ()
pre sd = do
  _ <- partSubscribe (subKeyboard $ sdSubs sd) (exitOnQ (doNextStep sd))
  _ <- partSubscribe (subWindow $ sdSubs sd) (exitOnWindowClose (doNextStep sd))
  _ <- partSubscribe (subJoystick $ sdSubs sd) (joyConnectDisconnect (sdJoys sd))
  return ()

exitOnQ :: MVar Bool -> KeyboardMessage -> Affection ()
exitOnQ nextStep (MsgKeyboardEvent _ _ _ _ sym) =
  case SDL.keysymKeycode sym of
    SDL.KeycodeQ -> do
      liftIO $ logIO Debug "Yo dog I heard..."
      void $ liftIO $ swapMVar nextStep False
    _ -> return ()

exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
exitOnWindowClose nextStep wm =
  case wm of
    MsgWindowClose _ _ -> do
      liftIO $ logIO Debug "I heard another one..."
      void $ liftIO $ swapMVar nextStep False
    _ -> return ()

joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection ()
joyConnectDisconnect mvjs msg = do
  mj <- joystickAutoConnect msg
  when (isJust mj) $ do
    js <- liftIO $ readMVar mvjs
    void $ liftIO $ swapMVar mvjs (fromJust mj : js)
  js <- liftIO $ readMVar mvjs
  njs <- joystickAutoDisconnect js msg
  liftIO $ putMVar mvjs njs

handle :: StateData -> [SDL.EventPayload] -> Affection ()
handle sd es = do
  let (Subsystems a b c d) = sdSubs sd
  leftovers <- consumeSDLEvents a
    =<< consumeSDLEvents b
    =<< consumeSDLEvents c
    =<< consumeSDLEvents d es
  mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e))
    leftovers

update :: StateData -> Double -> Affection ()
update _ _ = return ()

draw :: StateData -> Affection ()
draw _ = return ()

clean :: StateData -> IO ()
clean _ = return ()

generalSubscribers
  :: TVar [(UUID, msg -> Affection ())]
  -> Affection [msg -> Affection ()]
generalSubscribers t = do
  subTups <- liftIO $ readTVarIO t
  return $ map snd subTups

generalSubscribe
  :: TVar [(UUID, msg -> Affection ())]
  -> (msg -> Affection())
  -> Affection UUID
generalSubscribe t funct = do
  uuid <- genUUID
  liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
  return uuid

generalUnSubscribe
  :: TVar [(UUID, msg -> Affection ())]
  -> UUID
  -> Affection ()
generalUnSubscribe t uuid =
  liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))