Types.hs

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

module Types where

import Affection

import Data.Matrix as M

import NanoVG

import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)

data UserData = UserData
  { lifeMat    :: Matrix Word
  , foodMat    :: Matrix Word
  , timeMat    :: Matrix Word
  , subsystems :: Subsystems
  , nano       :: Context
  , lastUpdate :: Int
  }

data Subsystems = Subsystems
  { subWindow   :: Types.Window
  , subKeyboard :: Types.Keyboard
  }

newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])

newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])

instance Participant Types.Window UserData where
  type Mesg Types.Window UserData = WindowMessage

  partSubscribers (Window t) = do
    subTups <- liftIO $ readTVarIO t
    return $ map snd subTups

  partSubscribe (Window t) = generalSubscribe t

  partUnSubscribe (Window t) = generalUnSubscribe t

instance SDLSubsystem Types.Window UserData where
  consumeSDLEvents = consumeSDLWindowEvents

instance Participant Keyboard UserData where
  type Mesg Keyboard UserData = KeyboardMessage

  partSubscribers (Keyboard t) = do
    subTups <- liftIO $ readTVarIO t
    return $ map snd subTups

  partSubscribe (Keyboard t) = generalSubscribe t

  partUnSubscribe (Keyboard t) = generalUnSubscribe t

instance SDLSubsystem Keyboard UserData where
  consumeSDLEvents = consumeSDLKeyboardEvents

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

generalUnSubscribe
  :: TVar [(UUID, msg -> Affection UserData ())]
  -> UUID
  -> Affection UserData ()
generalUnSubscribe t uuid =
  liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
  where
    filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool
    filterMsg (u, _) p = u /= p