diff --git a/affection.cabal b/affection.cabal index dfeec64..378b5c5 100644 --- a/affection.cabal +++ b/affection.cabal @@ -68,10 +68,8 @@ library , Affection.Logging , Affection.Types , Affection.StateMachine - , Affection.MouseInteractable , Affection.Util , Affection.MessageBus - , Affection.MessageBus.Util , Affection.MessageBus.Class , Affection.MessageBus.Message , Affection.MessageBus.Message.Class diff --git a/examples/example00/Main.hs b/examples/example00/Main.hs index ae1f9e0..c496e67 100644 --- a/examples/example00/Main.hs +++ b/examples/example00/Main.hs @@ -1,13 +1,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -import Affection -import qualified SDL +import Affection as A import Control.Concurrent.STM import Control.Monad.IO.Class (liftIO) import Control.Monad (when) +import qualified SDL hiding (Window(..)) + import Data.Maybe (isJust, fromJust) data StateData = StateData @@ -16,10 +17,10 @@ data StateData = StateData } data Subsystems = Subsystems - { subWindow :: Window - , subMouse :: Mouse - , subKeyboard :: Keyboard - , subJoystick :: Joystick + { subWindow :: Main.Window + , subMouse :: Main.Mouse + , subKeyboard :: Main.Keyboard + , subJoystick :: Main.Joystick } newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) @@ -50,8 +51,8 @@ generalUnSubscribe generalUnSubscribe t uuid = liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) -instance Participant Window StateData where - type Mesg Window StateData = WindowMessage +instance Participant Main.Window StateData where + type Mesg Main.Window StateData = WindowMessage partSubscribers (Window t) = generalSubscribers t @@ -59,7 +60,7 @@ instance Participant Window StateData where partUnSubscribe (Window t) = generalUnSubscribe t -instance SDLSubsystem Window StateData where +instance SDLSubsystem Main.Window StateData where consumeSDLEvents = consumeSDLWindowEvents instance Participant Mouse StateData where @@ -176,7 +177,6 @@ handle es = do =<< consumeSDLEvents c =<< consumeSDLEvents d es mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " ++ show e) leftovers - return () update _ = return () diff --git a/examples/example01/Main.hs b/examples/example01/Main.hs index ae9fa98..4f14c51 100644 --- a/examples/example01/Main.hs +++ b/examples/example01/Main.hs @@ -152,89 +152,77 @@ handle es = do update :: Double -> Affection UserData () update _ = do ud <- getAffection - -- now <- getElapsedTime - when (True) $ do - newList <- mapM (\coord -> do - let x = (coord `mod` 60) + 1 - y = (coord `div` 60) + 1 - subm - | x == 1 && y == 1 = - (submatrix 60 60 60 60 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud)) - <-> - (submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud)) - | x == 1 && y == 60 = - (submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud)) - <-> - (submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud)) - | x == 60 && y == 1 = - (submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud)) - <-> - (submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud)) - | x == 60 && y == 60 = - (submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud)) - <-> - (submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud)) - | x == 1 = - (submatrix (y - 1) (y + 1) 60 60 (lifeMat ud)) - <|> - (submatrix (y - 1) (y + 1) 1 2 (lifeMat ud)) - | y == 1 = - (submatrix 60 60 (x - 1) (x + 1) (lifeMat ud)) - <-> - (submatrix 1 2 (x - 1) (x + 1) (lifeMat ud)) - | x == 60 = - (submatrix (y - 1) (y + 1) 59 60 (lifeMat ud)) - <|> - (submatrix (y - 1) (y + 1) 1 1 (lifeMat ud)) - | y == 60 = - (submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud)) - <-> - (submatrix 1 1 (x - 1) (x + 1) (lifeMat ud)) - | otherwise = - submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud) - life = countLife subm - if (lifeMat ud) M.! (y, x) == 1 - then if life == 2 || life == 3 - then if foodMat ud M.! (y, x) > 0 - then return (1, (foodMat ud M.! (y, x)) - 1, 0) - else return (0, foodMat ud M.! (y, x), 1) - else return (0, foodMat ud M.! (y, x), 1) - else if life == 3 - then if foodMat ud M.! (y, x) > 0 - then return (1, (foodMat ud M.! (y, x)) - 1, 0) - else return - ( 0 - , if timeMat ud M.! (y, x) > 10 - then min 10 ((foodMat ud M.! (y, x)) + 1) - else foodMat ud M.! (y, x) - , timeMat ud M.! (y, x) + 1 - ) - else return - ( 0 - , if timeMat ud M.! (y, x) > 10 - then min 10 ((foodMat ud M.! (y, x)) + 1) - else foodMat ud M.! (y, x) - , (timeMat ud M.! (y, x)) + 1 - ) - ) [0..3599] - let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList) - let newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList) - let newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList) - if (newLifeMat == M.zero 60 60) - then - reload - else - putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud) - { lifeMat = newLifeMat - , foodMat = newFoodMat - , timeMat = newTimeMat - -- , lastUpdate = floor now - } + newList <- mapM (\coord -> do + let x = (coord `mod` 60) + 1 + y = (coord `div` 60) + 1 + subm + | x == 1 && y == 1 = + submatrix 60 60 60 60 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud) + <-> + submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud) + | x == 1 && y == 60 = + submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud) + <-> + submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud) + | x == 60 && y == 1 = + submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud) + <-> + submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud) + | x == 60 && y == 60 = + submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud) + <-> + submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud) + | x == 1 = + submatrix (y - 1) (y + 1) 60 60 (lifeMat ud) + <|> + submatrix (y - 1) (y + 1) 1 2 (lifeMat ud) + | y == 1 = + submatrix 60 60 (x - 1) (x + 1) (lifeMat ud) + <-> + submatrix 1 2 (x - 1) (x + 1) (lifeMat ud) + | x == 60 = + submatrix (y - 1) (y + 1) 59 60 (lifeMat ud) + <|> + submatrix (y - 1) (y + 1) 1 1 (lifeMat ud) + | y == 60 = + submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud) + <-> + submatrix 1 1 (x - 1) (x + 1) (lifeMat ud) + | otherwise = + submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud) + life = countLife subm + if lifeMat ud M.! (y, x) == 1 + then if life == 2 || life == 3 && foodMat ud M.! (y, x) > 0 + then return (1, (foodMat ud M.! (y, x)) - 1, 0) + else return (0, foodMat ud M.! (y, x), 1) + else if life == 3 && foodMat ud M.! (y, x) > 0 + then return (1, (foodMat ud M.! (y, x)) - 1, 0) + else return + ( 0 + , if timeMat ud M.! (y, x) > 10 + then min 10 ((foodMat ud M.! (y, x)) + 1) + else foodMat ud M.! (y, x) + , timeMat ud M.! (y, x) + 1 + ) + ) [0..3599] + let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList) + let newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList) + let newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList) + if newLifeMat == M.zero 60 60 + then + reload + else + putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud) + { lifeMat = newLifeMat + , foodMat = newFoodMat + , timeMat = newTimeMat + -- , lastUpdate = floor now + } countLife :: Matrix Word -> Word countLife mat = res - (mat M.! (2, 2)) where - res = foldr (\a acc -> acc + a) 0 mat + res = foldr (flip (+)) 0 mat draw :: Affection UserData () draw = do @@ -250,10 +238,10 @@ draw = do -- logIO A.Debug $ show mult beginPath ctx rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10 - if (mult == 1) - then do + if mult == 1 + then fillColor ctx (rgba 255 255 255 255) - else do + else fillColor ctx (rgba 0 (fromIntegral $ 25 * (foodMat ud M.! (x+1, y+1))) 0 255) fill ctx ) [0..3599] diff --git a/examples/example01/Types.hs b/examples/example01/Types.hs index 9fea586..3be0da5 100644 --- a/examples/example01/Types.hs +++ b/examples/example01/Types.hs @@ -22,16 +22,16 @@ data UserData = UserData } data Subsystems = Subsystems - { subWindow :: Window - , subKeyboard :: Keyboard + { subWindow :: Types.Window + , subKeyboard :: Types.Keyboard } newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())]) newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) -instance Participant Window UserData where - type Mesg Window UserData = WindowMessage +instance Participant Types.Window UserData where + type Mesg Types.Window UserData = WindowMessage partSubscribers (Window t) = do subTups <- liftIO $ readTVarIO t @@ -41,7 +41,7 @@ instance Participant Window UserData where partUnSubscribe (Window t) = generalUnSubscribe t -instance SDLSubsystem Window UserData where +instance SDLSubsystem Types.Window UserData where consumeSDLEvents = consumeSDLWindowEvents instance Participant Keyboard UserData where diff --git a/src/Affection.hs b/src/Affection.hs index a77e4e2..1daf842 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -21,11 +21,8 @@ import Control.Monad.IO.Class (liftIO) import Foreign.C.Types (CInt(..)) -import Debug.Trace - import Affection.Types as A import Affection.StateMachine as A -import Affection.MouseInteractable as A import Affection.Util as A import Affection.MessageBus as A import Affection.Subsystems as A @@ -88,10 +85,7 @@ withAffection AffectionConfig{..} = do (_, nState) <- runStateT ( A.runState $ do liftIO $ logIO Debug "Starting Loop" preLoop - whileM_ (do - current <- get - return $ not $ A.quitEvent current - ) + whileM_ (not . A.quitEvent current <$> get) (do -- get state ad <- get diff --git a/src/Affection/Logging.hs b/src/Affection/Logging.hs index e64ed7c..f18b30e 100644 --- a/src/Affection/Logging.hs +++ b/src/Affection/Logging.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} -module Affection.Logging where --- ^ This module defines the logging capability of Affection, whis is derived +-- | This module defines the logging capability of Affection, whis is derived -- from "Debug.Trace". +module Affection.Logging where import Debug.Trace diff --git a/src/Affection/MessageBus.hs b/src/Affection/MessageBus.hs index d22edbb..6ae83e4 100644 --- a/src/Affection/MessageBus.hs +++ b/src/Affection/MessageBus.hs @@ -5,6 +5,5 @@ module Affection.MessageBus import Affection.MessageBus.Class as M import Affection.MessageBus.Message as M -import Affection.MessageBus.Util as M import Affection.MessageBus.Message as Msg diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 16ca2bc..ffa99a6 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -3,7 +3,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ExistentialQuantification #-} -module Affection.MessageBus.Class where +module Affection.MessageBus.Class + ( Participant(..) + , genUUID + , UUID + ) where import Affection.MessageBus.Message import Affection.Types diff --git a/src/Affection/MessageBus/Message/JoystickMessage.hs b/src/Affection/MessageBus/Message/JoystickMessage.hs index eb5c0e2..13fe3f2 100644 --- a/src/Affection/MessageBus/Message/JoystickMessage.hs +++ b/src/Affection/MessageBus/Message/JoystickMessage.hs @@ -7,21 +7,21 @@ module Affection.MessageBus.Message.JoystickMessage , SDL.JoyButtonState , SDL.JoyDeviceConnection -- | Number exports - , Word8(..) - , Int16(..) - , Int32(..) + , Word8 + , Int16 + , Int32 ) where import Affection.MessageBus.Message.Class -import Data.Word (Word8(..)) -import Data.Int (Int32(..), Int16(..)) +import Data.Word (Word8) +import Data.Int (Int32, Int16) import qualified SDL import Linear (V2(..)) --- Datatype for handling all possible joystick events handed over from sdl2 +-- | Datatype for handling all possible joystick events handed over from sdl2 data JoystickMessage = MsgJoystickAxis -- ^ Movement of a Joystick axis { msgJAWhen :: Double -- ^ Time of event diff --git a/src/Affection/MessageBus/Message/MouseMessage.hs b/src/Affection/MessageBus/Message/MouseMessage.hs index 0435650..37abc84 100644 --- a/src/Affection/MessageBus/Message/MouseMessage.hs +++ b/src/Affection/MessageBus/Message/MouseMessage.hs @@ -10,8 +10,8 @@ module Affection.MessageBus.Message.MouseMessage import Affection.MessageBus.Message.Class -import Data.Word (Word8(..)) -import Data.Int (Int32(..)) +import Data.Word (Word8) +import Data.Int (Int32) import qualified SDL diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs index 806b46c..107c7b2 100644 --- a/src/Affection/MessageBus/Message/WindowMessage.hs +++ b/src/Affection/MessageBus/Message/WindowMessage.hs @@ -6,7 +6,7 @@ module Affection.MessageBus.Message.WindowMessage import Affection.MessageBus.Message.Class -import Data.Int (Int32(..)) +import Data.Int (Int32) import qualified SDL diff --git a/src/Affection/Subsystems/AffectionJoystick.hs b/src/Affection/Subsystems/AffectionJoystick.hs index 69691b6..217be1d 100644 --- a/src/Affection/Subsystems/AffectionJoystick.hs +++ b/src/Affection/Subsystems/AffectionJoystick.hs @@ -5,14 +5,12 @@ module Affection.Subsystems.AffectionJoystick where import Affection.MessageBus -import Affection.Subsystems.Class import Affection.Types import Affection.Util import Affection.Logging import Control.Monad (filterM) import Control.Monad.IO.Class (liftIO) -import Control.Concurrent.STM import qualified Data.Vector as V @@ -86,8 +84,8 @@ joystickAutoConnect -- ^ Returns a joystick descriptor, if successful joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do [descr] <- V.toList <$> - (return . V.filter (\(SDL.JoystickDevice _ id) -> id == CInt which) - =<< SDL.availableJoysticks) + (V.filter (\(SDL.JoystickDevice _ i) -> i == CInt which) <$> + SDL.availableJoysticks) logIO Verbose $ "Connecting Joystick " ++ show which ++ " " ++ show descr Just <$> SDL.openJoystick descr joystickAutoConnect _ = return Nothing @@ -103,7 +101,7 @@ joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) = liftIO $ do joyIds <- mapM SDL.getJoystickID js logIO Verbose $ "These are the Joysticks connected: " ++ show joyIds - [d] <- filterM (\j -> return . (which ==) =<< SDL.getJoystickID j) js + [d] <- filterM ((which ==) <$> SDL.getJoystickID) js logIO Verbose $ "disconnected joysticks: " ++ show d logIO Verbose $ "Disconnecting Joystick " ++ show which SDL.closeJoystick d diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index 9d23df9..c2a1b58 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -7,10 +7,6 @@ module Affection.Subsystems.AffectionKeyboard where import Affection.Types import Affection.Util import Affection.MessageBus -import Affection.Subsystems.Class - -import Control.Concurrent.STM as STM -import Control.Monad.IO.Class (liftIO) import qualified SDL diff --git a/src/Affection/Subsystems/AffectionMouse.hs b/src/Affection/Subsystems/AffectionMouse.hs index ace9010..01861f3 100644 --- a/src/Affection/Subsystems/AffectionMouse.hs +++ b/src/Affection/Subsystems/AffectionMouse.hs @@ -5,13 +5,9 @@ module Affection.Subsystems.AffectionMouse where import Affection.MessageBus -import Affection.Subsystems.Class import Affection.Types import Affection.Util -import Control.Monad.IO.Class (liftIO) -import Control.Concurrent.STM - import Linear.Affine (unP) import qualified SDL diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 2ec60ae..a9c2622 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -9,10 +9,6 @@ module Affection.Subsystems.AffectionWindow where import Affection.Types import Affection.Util import Affection.MessageBus -import Affection.Subsystems.Class - -import Control.Concurrent.STM as STM -import Control.Monad.IO.Class (liftIO) import qualified SDL diff --git a/src/Affection/Subsystems/Class.hs b/src/Affection/Subsystems/Class.hs index 4509332..d9504c5 100644 --- a/src/Affection/Subsystems/Class.hs +++ b/src/Affection/Subsystems/Class.hs @@ -3,7 +3,6 @@ module Affection.Subsystems.Class where import Affection.Types -import Affection.MessageBus import qualified SDL diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 0785d43..32210de 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -1,26 +1,25 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} module Affection.Types - ( Affection(..) + ( Affection , AffectionConfig(..) , AffectionData(..) - , AffectionStateInner(..) + , AffectionStateInner , AffectionState(..) , InitComponents(..) - , Angle(..) + , Angle -- | SDL reexports , SDL.WindowConfig(..) , SDL.WindowMode(..) , SDL.EventPayload(..) - , SDL.InitFlags(..) - , SDL.Window(..) - , SDL.GLContext(..) + , SDL.InitFlag(..) + , SDL.Window + , SDL.GLContext ) where import qualified SDL.Init as SDL import qualified SDL.Video as SDL import qualified SDL.Event as SDL import qualified Data.Text as T -import Data.Map.Strict as M import Control.Monad.IO.Class import Control.Monad.State.Strict @@ -28,10 +27,6 @@ import qualified Control.Monad.Parallel as MP import System.Clock (TimeSpec) -import Foreign.Ptr (Ptr) - -import Affection.MessageBus.Message - -- | Configuration for the aplication. needed at startup. data AffectionConfig us = AffectionConfig { initComponents :: InitComponents @@ -71,8 +66,6 @@ data AffectionData us = AffectionData , glContext :: SDL.GLContext -- ^ OpenGL rendering context , screenMode :: SDL.WindowMode -- ^ current screen mode , drawDimensions :: (Int, Int) -- ^ Dimensions of target surface - , drawStride :: Int -- ^ Stride of target buffer - , drawCPP :: Int -- ^ Number of components per pixel , elapsedTime :: Double -- ^ Elapsed time in seconds , deltaTime :: Double -- ^ Elapsed time in seconds since last tick , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) diff --git a/src/Affection/Util.hs b/src/Affection/Util.hs index 16fbbf8..e5bcab9 100644 --- a/src/Affection/Util.hs +++ b/src/Affection/Util.hs @@ -19,9 +19,7 @@ preHandleEvents evs = -- | Return the userstate to the user getAffection :: Affection us us -getAffection = do - ad <- get - return $ userState ad +getAffection = gets userState -- | Put altered user state back putAffection @@ -40,12 +38,10 @@ delaySec dur = SDL.delay (fromIntegral $ dur * 1000) -- | Get time since start but always the same in the current tick. getElapsedTime :: Affection us Double -getElapsedTime = - elapsedTime <$> get +getElapsedTime = gets elapsedTime getDelta :: Affection us Double -getDelta = - deltaTime <$> get +getDelta = gets deltaTime quit :: Affection us () quit = do