{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Types.Subsystems where

import Affection

import Control.Concurrent.STM

data Subsystems = Subsystems
  { subWindow     :: SubWindow
  , subMouse      :: SubMouse
  , subKeyboard   :: SubKeyboard
  , subTranslator :: SubTranslator
  }

newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
newtype SubTranslator = SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())])

data TranslatorMessage = TranslatorMessage
  { tmAction :: Action
  , tmTime   :: Double
  }
  deriving (Eq, Show)

instance Message TranslatorMessage where
  msgTime (TranslatorMessage _ t) = t

data Action
  = MoveLeft
  | MoveRight
  | Jump
  | JumpDown
  | Activate
  | ReleasePowerup1
  | ReleasePowerup2
  | ReleasePowerup3
  | Spit
  | Pause
  deriving (Enum, Eq, Show)

instance Participant SubWindow where
  type Mesg SubWindow = WindowMessage

  partSubscribers (SubWindow t) = generalSubscribers t

  partSubscribe (SubWindow t) = generalSubscribe t

  partUnSubscribe (SubWindow t) = generalUnSubscribe t

instance SDLSubsystem SubWindow where
  consumeSDLEvents = consumeSDLWindowEvents

instance Participant SubMouse where
  type Mesg SubMouse = MouseMessage

  partSubscribers (SubMouse t) = generalSubscribers t

  partSubscribe (SubMouse t) = generalSubscribe t

  partUnSubscribe (SubMouse t) = generalUnSubscribe t

instance SDLSubsystem SubMouse where
  consumeSDLEvents = consumeSDLMouseEvents

instance Participant SubKeyboard where
  type Mesg SubKeyboard = KeyboardMessage

  partSubscribers (SubKeyboard t) = generalSubscribers t

  partSubscribe (SubKeyboard t) = generalSubscribe t

  partUnSubscribe (SubKeyboard t) = generalUnSubscribe t

instance SDLSubsystem SubKeyboard where
  consumeSDLEvents = consumeSDLKeyboardEvents

instance Participant SubTranslator where
  type Mesg SubTranslator = TranslatorMessage

  partSubscribers (SubTranslator t) = generalSubscribers t

  partSubscribe (SubTranslator t) = generalSubscribe t

  partUnSubscribe (SubTranslator t) = generalUnSubscribe t

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
  uu <- genUUID
  liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
  return uu

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