more cleanup

This commit is contained in:
nek0 2018-09-25 16:10:36 +02:00
parent c804a2e013
commit 6bb0076158
18 changed files with 114 additions and 157 deletions

View File

@ -68,10 +68,8 @@ library
, Affection.Logging , Affection.Logging
, Affection.Types , Affection.Types
, Affection.StateMachine , Affection.StateMachine
, Affection.MouseInteractable
, Affection.Util , Affection.Util
, Affection.MessageBus , Affection.MessageBus
, Affection.MessageBus.Util
, Affection.MessageBus.Class , Affection.MessageBus.Class
, Affection.MessageBus.Message , Affection.MessageBus.Message
, Affection.MessageBus.Message.Class , Affection.MessageBus.Message.Class

View File

@ -1,13 +1,14 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
import Affection import Affection as A
import qualified SDL
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad (when) import Control.Monad (when)
import qualified SDL hiding (Window(..))
import Data.Maybe (isJust, fromJust) import Data.Maybe (isJust, fromJust)
data StateData = StateData data StateData = StateData
@ -16,10 +17,10 @@ data StateData = StateData
} }
data Subsystems = Subsystems data Subsystems = Subsystems
{ subWindow :: Window { subWindow :: Main.Window
, subMouse :: Mouse , subMouse :: Main.Mouse
, subKeyboard :: Keyboard , subKeyboard :: Main.Keyboard
, subJoystick :: Joystick , subJoystick :: Main.Joystick
} }
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
@ -50,8 +51,8 @@ generalUnSubscribe
generalUnSubscribe t uuid = generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance Participant Window StateData where instance Participant Main.Window StateData where
type Mesg Window StateData = WindowMessage type Mesg Main.Window StateData = WindowMessage
partSubscribers (Window t) = generalSubscribers t partSubscribers (Window t) = generalSubscribers t
@ -59,7 +60,7 @@ instance Participant Window StateData where
partUnSubscribe (Window t) = generalUnSubscribe t partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Window StateData where instance SDLSubsystem Main.Window StateData where
consumeSDLEvents = consumeSDLWindowEvents consumeSDLEvents = consumeSDLWindowEvents
instance Participant Mouse StateData where instance Participant Mouse StateData where
@ -176,7 +177,6 @@ handle es = do
=<< consumeSDLEvents c =<< consumeSDLEvents c
=<< consumeSDLEvents d es =<< consumeSDLEvents d es
mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " ++ show e) leftovers mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " ++ show e) leftovers
return ()
update _ = return () update _ = return ()

View File

@ -152,89 +152,77 @@ handle es = do
update :: Double -> Affection UserData () update :: Double -> Affection UserData ()
update _ = do update _ = do
ud <- getAffection ud <- getAffection
-- now <- getElapsedTime newList <- mapM (\coord -> do
when (True) $ do let x = (coord `mod` 60) + 1
newList <- mapM (\coord -> do y = (coord `div` 60) + 1
let x = (coord `mod` 60) + 1 subm
y = (coord `div` 60) + 1 | x == 1 && y == 1 =
subm submatrix 60 60 60 60 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud)
| 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 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud)) submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 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 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud)) submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (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 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud)) submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 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 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud)) submatrix (y - 1) (y + 1) 60 60 (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 (y - 1) (y + 1) 1 2 (lifeMat ud)) submatrix 60 60 (x - 1) (x + 1) (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 1 2 (x - 1) (x + 1) (lifeMat ud)) submatrix (y - 1) (y + 1) 59 60 (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 (y - 1) (y + 1) 1 1 (lifeMat ud)) submatrix 59 60 (x -1 ) (x + 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 1 1 (x - 1) (x + 1) (lifeMat ud)) submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud)
| otherwise = life = countLife subm
submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud) if lifeMat ud M.! (y, x) == 1
life = countLife subm then if life == 2 || life == 3 && foodMat ud M.! (y, x) > 0
if (lifeMat ud) M.! (y, x) == 1 then return (1, (foodMat ud M.! (y, x)) - 1, 0)
then if life == 2 || life == 3 else return (0, foodMat ud M.! (y, x), 1)
then if foodMat ud M.! (y, x) > 0 else if life == 3 && foodMat ud M.! (y, x) > 0
then return (1, (foodMat ud M.! (y, x)) - 1, 0) then return (1, (foodMat ud M.! (y, x)) - 1, 0)
else return (0, foodMat ud M.! (y, x), 1) else return
else return (0, foodMat ud M.! (y, x), 1) ( 0
else if life == 3 , if timeMat ud M.! (y, x) > 10
then if foodMat ud M.! (y, x) > 0 then min 10 ((foodMat ud M.! (y, x)) + 1)
then return (1, (foodMat ud M.! (y, x)) - 1, 0) else foodMat ud M.! (y, x)
else return , timeMat ud M.! (y, x) + 1
( 0 )
, if timeMat ud M.! (y, x) > 10 ) [0..3599]
then min 10 ((foodMat ud M.! (y, x)) + 1) let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
else foodMat ud M.! (y, x) let newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList)
, timeMat ud M.! (y, x) + 1 let newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
) if newLifeMat == M.zero 60 60
else return then
( 0 reload
, if timeMat ud M.! (y, x) > 10 else
then min 10 ((foodMat ud M.! (y, x)) + 1) putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud)
else foodMat ud M.! (y, x) { lifeMat = newLifeMat
, (timeMat ud M.! (y, x)) + 1 , foodMat = newFoodMat
) , timeMat = newTimeMat
) [0..3599] -- , lastUpdate = floor now
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 :: Matrix Word -> Word
countLife mat = res - (mat M.! (2, 2)) countLife mat = res - (mat M.! (2, 2))
where where
res = foldr (\a acc -> acc + a) 0 mat res = foldr (flip (+)) 0 mat
draw :: Affection UserData () draw :: Affection UserData ()
draw = do draw = do
@ -250,10 +238,10 @@ draw = do
-- logIO A.Debug $ show mult -- logIO A.Debug $ show mult
beginPath ctx beginPath ctx
rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10 rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
if (mult == 1) if mult == 1
then do then
fillColor ctx (rgba 255 255 255 255) 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) fillColor ctx (rgba 0 (fromIntegral $ 25 * (foodMat ud M.! (x+1, y+1))) 0 255)
fill ctx fill ctx
) [0..3599] ) [0..3599]

View File

@ -22,16 +22,16 @@ data UserData = UserData
} }
data Subsystems = Subsystems data Subsystems = Subsystems
{ subWindow :: Window { subWindow :: Types.Window
, subKeyboard :: Keyboard , subKeyboard :: Types.Keyboard
} }
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())]) newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
instance Participant Window UserData where instance Participant Types.Window UserData where
type Mesg Window UserData = WindowMessage type Mesg Types.Window UserData = WindowMessage
partSubscribers (Window t) = do partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
@ -41,7 +41,7 @@ instance Participant Window UserData where
partUnSubscribe (Window t) = generalUnSubscribe t partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Window UserData where instance SDLSubsystem Types.Window UserData where
consumeSDLEvents = consumeSDLWindowEvents consumeSDLEvents = consumeSDLWindowEvents
instance Participant Keyboard UserData where instance Participant Keyboard UserData where

View File

@ -21,11 +21,8 @@ import Control.Monad.IO.Class (liftIO)
import Foreign.C.Types (CInt(..)) import Foreign.C.Types (CInt(..))
import Debug.Trace
import Affection.Types as A import Affection.Types as A
import Affection.StateMachine as A import Affection.StateMachine as A
import Affection.MouseInteractable as A
import Affection.Util as A import Affection.Util as A
import Affection.MessageBus as A import Affection.MessageBus as A
import Affection.Subsystems as A import Affection.Subsystems as A
@ -88,10 +85,7 @@ withAffection AffectionConfig{..} = do
(_, nState) <- runStateT ( A.runState $ do (_, nState) <- runStateT ( A.runState $ do
liftIO $ logIO Debug "Starting Loop" liftIO $ logIO Debug "Starting Loop"
preLoop preLoop
whileM_ (do whileM_ (not . A.quitEvent current <$> get)
current <- get
return $ not $ A.quitEvent current
)
(do (do
-- get state -- get state
ad <- get ad <- get

View File

@ -1,7 +1,7 @@
{-# LANGUAGE CPP #-} {-# 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". -- from "Debug.Trace".
module Affection.Logging where
import Debug.Trace import Debug.Trace

View File

@ -5,6 +5,5 @@ module Affection.MessageBus
import Affection.MessageBus.Class as M import Affection.MessageBus.Class as M
import Affection.MessageBus.Message as M import Affection.MessageBus.Message as M
import Affection.MessageBus.Util as M
import Affection.MessageBus.Message as Msg import Affection.MessageBus.Message as Msg

View File

@ -3,7 +3,11 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
module Affection.MessageBus.Class where module Affection.MessageBus.Class
( Participant(..)
, genUUID
, UUID
) where
import Affection.MessageBus.Message import Affection.MessageBus.Message
import Affection.Types import Affection.Types

View File

@ -7,21 +7,21 @@ module Affection.MessageBus.Message.JoystickMessage
, SDL.JoyButtonState , SDL.JoyButtonState
, SDL.JoyDeviceConnection , SDL.JoyDeviceConnection
-- | Number exports -- | Number exports
, Word8(..) , Word8
, Int16(..) , Int16
, Int32(..) , Int32
) where ) where
import Affection.MessageBus.Message.Class import Affection.MessageBus.Message.Class
import Data.Word (Word8(..)) import Data.Word (Word8)
import Data.Int (Int32(..), Int16(..)) import Data.Int (Int32, Int16)
import qualified SDL import qualified SDL
import Linear (V2(..)) 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 data JoystickMessage
= MsgJoystickAxis -- ^ Movement of a Joystick axis = MsgJoystickAxis -- ^ Movement of a Joystick axis
{ msgJAWhen :: Double -- ^ Time of event { msgJAWhen :: Double -- ^ Time of event

View File

@ -10,8 +10,8 @@ module Affection.MessageBus.Message.MouseMessage
import Affection.MessageBus.Message.Class import Affection.MessageBus.Message.Class
import Data.Word (Word8(..)) import Data.Word (Word8)
import Data.Int (Int32(..)) import Data.Int (Int32)
import qualified SDL import qualified SDL

View File

@ -6,7 +6,7 @@ module Affection.MessageBus.Message.WindowMessage
import Affection.MessageBus.Message.Class import Affection.MessageBus.Message.Class
import Data.Int (Int32(..)) import Data.Int (Int32)
import qualified SDL import qualified SDL

View File

@ -5,14 +5,12 @@
module Affection.Subsystems.AffectionJoystick where module Affection.Subsystems.AffectionJoystick where
import Affection.MessageBus import Affection.MessageBus
import Affection.Subsystems.Class
import Affection.Types import Affection.Types
import Affection.Util import Affection.Util
import Affection.Logging import Affection.Logging
import Control.Monad (filterM) import Control.Monad (filterM)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM
import qualified Data.Vector as V import qualified Data.Vector as V
@ -86,8 +84,8 @@ joystickAutoConnect
-- ^ Returns a joystick descriptor, if successful -- ^ Returns a joystick descriptor, if successful
joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
[descr] <- V.toList <$> [descr] <- V.toList <$>
(return . V.filter (\(SDL.JoystickDevice _ id) -> id == CInt which) (V.filter (\(SDL.JoystickDevice _ i) -> i == CInt which) <$>
=<< SDL.availableJoysticks) SDL.availableJoysticks)
logIO Verbose $ "Connecting Joystick " ++ show which ++ " " ++ show descr logIO Verbose $ "Connecting Joystick " ++ show which ++ " " ++ show descr
Just <$> SDL.openJoystick descr Just <$> SDL.openJoystick descr
joystickAutoConnect _ = return Nothing joystickAutoConnect _ = return Nothing
@ -103,7 +101,7 @@ joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) =
liftIO $ do liftIO $ do
joyIds <- mapM SDL.getJoystickID js joyIds <- mapM SDL.getJoystickID js
logIO Verbose $ "These are the Joysticks connected: " ++ show joyIds 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 $ "disconnected joysticks: " ++ show d
logIO Verbose $ "Disconnecting Joystick " ++ show which logIO Verbose $ "Disconnecting Joystick " ++ show which
SDL.closeJoystick d SDL.closeJoystick d

View File

@ -7,10 +7,6 @@ module Affection.Subsystems.AffectionKeyboard where
import Affection.Types import Affection.Types
import Affection.Util import Affection.Util
import Affection.MessageBus import Affection.MessageBus
import Affection.Subsystems.Class
import Control.Concurrent.STM as STM
import Control.Monad.IO.Class (liftIO)
import qualified SDL import qualified SDL

View File

@ -5,13 +5,9 @@
module Affection.Subsystems.AffectionMouse where module Affection.Subsystems.AffectionMouse where
import Affection.MessageBus import Affection.MessageBus
import Affection.Subsystems.Class
import Affection.Types import Affection.Types
import Affection.Util import Affection.Util
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM
import Linear.Affine (unP) import Linear.Affine (unP)
import qualified SDL import qualified SDL

View File

@ -9,10 +9,6 @@ module Affection.Subsystems.AffectionWindow where
import Affection.Types import Affection.Types
import Affection.Util import Affection.Util
import Affection.MessageBus import Affection.MessageBus
import Affection.Subsystems.Class
import Control.Concurrent.STM as STM
import Control.Monad.IO.Class (liftIO)
import qualified SDL import qualified SDL

View File

@ -3,7 +3,6 @@
module Affection.Subsystems.Class where module Affection.Subsystems.Class where
import Affection.Types import Affection.Types
import Affection.MessageBus
import qualified SDL import qualified SDL

View File

@ -1,26 +1,25 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
module Affection.Types module Affection.Types
( Affection(..) ( Affection
, AffectionConfig(..) , AffectionConfig(..)
, AffectionData(..) , AffectionData(..)
, AffectionStateInner(..) , AffectionStateInner
, AffectionState(..) , AffectionState(..)
, InitComponents(..) , InitComponents(..)
, Angle(..) , Angle
-- | SDL reexports -- | SDL reexports
, SDL.WindowConfig(..) , SDL.WindowConfig(..)
, SDL.WindowMode(..) , SDL.WindowMode(..)
, SDL.EventPayload(..) , SDL.EventPayload(..)
, SDL.InitFlags(..) , SDL.InitFlag(..)
, SDL.Window(..) , SDL.Window
, SDL.GLContext(..) , SDL.GLContext
) where ) where
import qualified SDL.Init as SDL import qualified SDL.Init as SDL
import qualified SDL.Video as SDL import qualified SDL.Video as SDL
import qualified SDL.Event as SDL import qualified SDL.Event as SDL
import qualified Data.Text as T import qualified Data.Text as T
import Data.Map.Strict as M
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.State.Strict import Control.Monad.State.Strict
@ -28,10 +27,6 @@ import qualified Control.Monad.Parallel as MP
import System.Clock (TimeSpec) import System.Clock (TimeSpec)
import Foreign.Ptr (Ptr)
import Affection.MessageBus.Message
-- | Configuration for the aplication. needed at startup. -- | Configuration for the aplication. needed at startup.
data AffectionConfig us = AffectionConfig data AffectionConfig us = AffectionConfig
{ initComponents :: InitComponents { initComponents :: InitComponents
@ -71,8 +66,6 @@ data AffectionData us = AffectionData
, glContext :: SDL.GLContext -- ^ OpenGL rendering context , glContext :: SDL.GLContext -- ^ OpenGL rendering context
, screenMode :: SDL.WindowMode -- ^ current screen mode , screenMode :: SDL.WindowMode -- ^ current screen mode
, drawDimensions :: (Int, Int) -- ^ Dimensions of target surface , 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 , elapsedTime :: Double -- ^ Elapsed time in seconds
, deltaTime :: Double -- ^ Elapsed time in seconds since last tick , deltaTime :: Double -- ^ Elapsed time in seconds since last tick
, sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock)

View File

@ -19,9 +19,7 @@ preHandleEvents evs =
-- | Return the userstate to the user -- | Return the userstate to the user
getAffection :: Affection us us getAffection :: Affection us us
getAffection = do getAffection = gets userState
ad <- get
return $ userState ad
-- | Put altered user state back -- | Put altered user state back
putAffection putAffection
@ -40,12 +38,10 @@ delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
-- | Get time since start but always the same in the current tick. -- | Get time since start but always the same in the current tick.
getElapsedTime :: Affection us Double getElapsedTime :: Affection us Double
getElapsedTime = getElapsedTime = gets elapsedTime
elapsedTime <$> get
getDelta :: Affection us Double getDelta :: Affection us Double
getDelta = getDelta = gets deltaTime
deltaTime <$> get
quit :: Affection us () quit :: Affection us ()
quit = do quit = do