nek0/affection
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

make example01 affectionate and working

Browse source
This commit is contained in:
nek0 2020-05-04 08:23:30 +02:00
parent 9ac25d5fca
commit a7eac3e392
2 changed files with 100 additions and 101 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

164
examples/example01/Main.hs
View file

@ -10,7 +10,7 @@ import qualified Graphics.Rendering.OpenGL as GL
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad (when) import Control.Monad
import Control.DeepSeq (deepseq) import Control.DeepSeq (deepseq)
import Data.Matrix as M import Data.Matrix as M
@ -60,7 +60,7 @@ main = do
, SDL.Windowed , SDL.Windowed
) )
] ]
} } :: AffectionConfig UserData
withAffection conf withAffection conf
load :: IO UserData load :: IO UserData
@ -76,7 +76,7 @@ load = do
-- logIO A.Debug $ prettyMatrix fullMatrix -- logIO A.Debug $ prettyMatrix fullMatrix
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())]) empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())]) empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())])
step <- NewMVar True step <- newMVar True
(\life food time -> UserData (\life food time -> UserData
{ subsystems = Subsystems { subsystems = Subsystems
(Window empty1) (Window empty1)
@ -94,50 +94,45 @@ load = do
pre :: UserData -> Affection () pre :: UserData -> Affection ()
pre ud = do pre ud = do
_ <- partSubscribe (subKeyboard $ subsystems sd) (exitOnEsc (doNextStep ud)) void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud))
_ <- partSubscribe (subKeyboard $ subsystems sd) (reloadOnR ud) void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud)
_ <- partSubscribe (subKeyboard $ subsystems sd) showFPS void $ partSubscribe (subKeyboard $ subsystems ud) showFPS
_ <- partSubscribe (subKeyboard $ subsystems sd) toggleFullScreen void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen
_ <- partSubscribe (subWindow $ subsystems sd) exitOnWindowClose void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud))
_ <- partSubscribe (subWindow $ subsystems sd) (fitViewport (600/600)) void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600))
now <- getElapsedTime
putAffection sd
toggleFullScreen :: KeyboardMessage -> Affection UserData () toggleFullScreen :: KeyboardMessage -> Affection ()
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym) toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
| otherwise = return () | otherwise = return ()
toggleFullScreen _ = return () toggleFullScreen _ = return ()
exitOnEsc :: KeyboardMessage -> Affection UserData () exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection ()
exitOnEsc (MsgKeyboardEvent _ _ SDL.Pressed False sym) = exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
case SDL.keysymKeycode sym of case SDL.keysymKeycode sym of
SDL.KeycodeEscape -> do SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Yo dog I heard..." liftIO $ logIO A.Debug "Yo dog I heard..."
quit void $ liftIO $ swapMVar step False
_ -> return () _ -> return ()
exitOnEsc _ = return () exitOnEsc _ _ = return ()
reloadOnR :: KeyboardMessage -> Affection UserData () reloadOnR :: UserData -> KeyboardMessage -> Affection ()
reloadOnR (MsgKeyboardEvent _ _ _ _ sym) = reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of case SDL.keysymKeycode sym of
SDL.KeycodeR -> reload SDL.KeycodeR -> reload ud
_ -> return () _ -> return ()
reloadOnR _ = return () reloadOnR _ _ = return ()
reload :: Affection UserData () reload :: UserData -> Affection ()
reload = do reload ud = do
ud <- getAffection
now <- getElapsedTime now <- getElapsedTime
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599] randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
let fullMatrix = fromList 60 60 randList let fullMatrix = fromList 60 60 randList
putAffection ud void $ liftIO $ swapMVar (lifeMat ud) fullMatrix
{ lifeMat = fullMatrix void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat 10))
, foodMat = fromList 60 60 (repeat 10) void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60)
, timeMat = M.zero 60 60
}
showFPS :: KeyboardMessage -> Affection UserData () showFPS :: KeyboardMessage -> Affection ()
showFPS (MsgKeyboardEvent _ _ _ _ sym) = showFPS (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of case SDL.keysymKeycode sym of
SDL.KeycodeF -> do SDL.KeycodeF -> do
@ -146,84 +141,87 @@ showFPS (MsgKeyboardEvent _ _ _ _ sym) =
_ -> return () _ -> return ()
showFPS _ = return () showFPS _ = return ()
exitOnWindowClose :: WindowMessage -> Affection UserData () exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
exitOnWindowClose wm = exitOnWindowClose step wm =
case wm of case wm of
MsgWindowClose _ _ -> do MsgWindowClose _ _ -> do
liftIO $ logIO A.Debug "I heard another one..." liftIO $ logIO A.Debug "I heard another one..."
quit void $ liftIO $ swapMVar step False
_ -> return () _ -> return ()
exitOnWindowClose _ = return () exitOnWindowClose _ _ = return ()
handle :: [SDL.EventPayload] -> Affection UserData () handle :: UserData -> [SDL.EventPayload] -> Affection ()
handle es = do handle ud es = do
(Subsystems a b) <- subsystems <$> getAffection let (Subsystems a b) = subsystems ud
_ <- consumeSDLEvents a =<< consumeSDLEvents b es _ <- consumeSDLEvents a =<< consumeSDLEvents b es
return () return ()
update :: Double -> Affection UserData () update :: UserData -> Double -> Affection ()
update _ = do update ud dt = do
ud <- getAffection -- liftIO $ logIO A.Debug ("FPS: " <> fromString (show (1/dt)))
pastLife <- liftIO $ readMVar (lifeMat ud)
pastFood <- liftIO $ readMVar (foodMat ud)
pastTime <- liftIO $ readMVar (timeMat ud)
newList <- mapM (\coord -> do newList <- mapM (\coord -> do
let x = (coord `mod` 60) + 1 let x = (coord `mod` 60) + 1
y = (coord `div` 60) + 1 y = (coord `div` 60) + 1
subm subm
| x == 1 && y == 1 = | x == 1 && y == 1 =
(submatrix 60 60 60 60 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud)) (submatrix 60 60 60 60 pastLife <|> submatrix 60 60 1 2 pastLife)
<-> <->
(submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud)) (submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife)
| x == 1 && y == 60 = | x == 1 && y == 60 =
(submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud)) (submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife)
<-> <->
(submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud)) (submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife)
| x == 60 && y == 1 = | x == 60 && y == 1 =
(submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud)) (submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife)
<-> <->
(submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud)) (submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife)
| x == 60 && y == 60 = | x == 60 && y == 60 =
(submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud)) (submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife)
<-> <->
(submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud)) (submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife)
| x == 1 = | x == 1 =
(submatrix (y - 1) (y + 1) 60 60 (lifeMat ud)) (submatrix (y - 1) (y + 1) 60 60 pastLife)
<|> <|>
(submatrix (y - 1) (y + 1) 1 2 (lifeMat ud)) (submatrix (y - 1) (y + 1) 1 2 pastLife)
| y == 1 = | y == 1 =
(submatrix 60 60 (x - 1) (x + 1) (lifeMat ud)) (submatrix 60 60 (x - 1) (x + 1) pastLife)
<-> <->
(submatrix 1 2 (x - 1) (x + 1) (lifeMat ud)) (submatrix 1 2 (x - 1) (x + 1) pastLife)
| x == 60 = | x == 60 =
(submatrix (y - 1) (y + 1) 59 60 (lifeMat ud)) (submatrix (y - 1) (y + 1) 59 60 pastLife)
<|> <|>
(submatrix (y - 1) (y + 1) 1 1 (lifeMat ud)) (submatrix (y - 1) (y + 1) 1 1 pastLife)
| y == 60 = | y == 60 =
(submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud)) (submatrix 59 60 (x -1 ) (x + 1) pastLife)
<-> <->
(submatrix 1 1 (x - 1) (x + 1) (lifeMat ud)) (submatrix 1 1 (x - 1) (x + 1) pastLife)
| otherwise = | otherwise =
(submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud)) (submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife)
life = countLife subm life = countLife subm
ret ret
| life == 0 && lifeMat ud M.! (y, x) == 0 = | life == 0 && pastLife M.! (y, x) == 0 =
( 0 ( 0
, if timeMat ud M.! (y, x) >= 10 , if pastTime M.! (y, x) >= 10
then min 10 (foodMat ud M.! (y, x) + 1) then min 10 (pastFood M.! (y, x) + 1)
else min 10 (foodMat ud M.! (y, x)) else min 10 (pastFood M.! (y, x))
, timeMat ud M.! (y, x) + 1 , pastTime M.! (y, x) + 1
) )
| otherwise = (1, 1, 1) | otherwise = (1, 1, 1)
if lifeMat ud M.! (y, x) == 1 if pastLife M.! (y, x) == 1
then if (life == 2 || life == 3) && foodMat ud M.! (y, x) > 0 then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0
then return (1, (foodMat ud M.! (y, x)) - 1, 0) then return (1, (pastFood M.! (y, x)) - 1, 0)
else return (0, foodMat ud M.! (y, x), 0) else return (0, pastFood M.! (y, x), 0)
else if life == 3 && foodMat ud M.! (y, x) > 0 else if life == 3 && pastFood M.! (y, x) > 0
then return (1, (foodMat ud M.! (y, x)) - 1, 0) then return (1, (pastFood M.! (y, x)) - 1, 0)
else return else return
( 0 ( 0
, if timeMat ud M.! (y, x) > 10 , if pastTime M.! (y, x) > 10
then min 10 ((foodMat ud M.! (y, x)) + 1) then min 10 ((pastFood M.! (y, x)) + 1)
else min 10 (foodMat ud M.! (y, x)) else min 10 (pastFood M.! (y, x))
, timeMat ud M.! (y, x) + 1 , pastTime M.! (y, x) + 1
) )
) [0..3599] ) [0..3599]
let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList) let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
@ -231,22 +229,22 @@ update _ = do
newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList) newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
if newLifeMat == M.zero 60 60 if newLifeMat == M.zero 60 60
then then
reload reload ud
else else do
putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud) ((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ())
{ lifeMat = newLifeMat void $ liftIO $ swapMVar (lifeMat ud) newLifeMat
--, foodMat = newFoodMat void $ liftIO $ swapMVar (timeMat ud) newTimeMat
, timeMat = newTimeMat -- void $ liftIO $ swapMVar (foodMat ud) newFoodMat
}
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 (flip (+)) 0 mat res = foldr (flip (+)) 0 mat
draw :: Affection UserData () draw :: UserData -> Affection ()
draw = do draw ud = do
ud <- getAffection life <- liftIO $ readMVar (lifeMat ud)
food <- liftIO $ readMVar (foodMat ud)
liftIO $ do liftIO $ do
beginFrame (nano ud) 600 600 1 beginFrame (nano ud) 600 600 1
save (nano ud) save (nano ud)
@ -254,7 +252,7 @@ draw = do
let x = coord `mod` 60 let x = coord `mod` 60
y = coord `div` 60 y = coord `div` 60
ctx = nano ud ctx = nano ud
mult = lifeMat ud M.! (x + 1, y + 1) mult = life M.! (x + 1, y + 1)
-- 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
@ -262,7 +260,7 @@ draw = do
then then
fillColor ctx (rgba 255 255 255 255) fillColor ctx (rgba 255 255 255 255)
else else
fillColor ctx (rgba 0 (fromIntegral $ 25 * (foodMat ud M.! (x+1, y+1))) 0 255) fillColor ctx (rgba 0 (fromIntegral $ 25 * (food M.! (x+1, y+1))) 0 255)
fill ctx fill ctx
) [0..3599] ) [0..3599]
restore (nano ud) restore (nano ud)

37
examples/example01/Types.hs
View file

@ -10,14 +10,15 @@ import Data.Matrix as M
import NanoVG import NanoVG
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO) import Control.Concurrent.MVar
data UserData = UserData data UserData = UserData
{ lifeMat :: Matrix Word { lifeMat :: MVar (Matrix Word)
, foodMat :: Matrix Word , foodMat :: MVar (Matrix Word)
, timeMat :: Matrix Word , timeMat :: MVar (Matrix Word)
, subsystems :: Subsystems , subsystems :: Subsystems
, nano :: Context , nano :: Context
, doNextStep :: MVar Bool
} }
data Subsystems = Subsystems data Subsystems = Subsystems
@ -25,12 +26,12 @@ data Subsystems = Subsystems
, subKeyboard :: Types.Keyboard , subKeyboard :: Types.Keyboard
} }
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())]) newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
instance Participant Types.Window UserData where instance Participant Types.Window where
type Mesg Types.Window UserData = WindowMessage type Mesg Types.Window = WindowMessage
partSubscribers (Window t) = do partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
@ -40,11 +41,11 @@ instance Participant Types.Window UserData where
partUnSubscribe (Window t) = generalUnSubscribe t partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Types.Window UserData where instance SDLSubsystem Types.Window where
consumeSDLEvents = consumeSDLWindowEvents consumeSDLEvents = consumeSDLWindowEvents
instance Participant Keyboard UserData where instance Participant Keyboard where
type Mesg Keyboard UserData = KeyboardMessage type Mesg Keyboard = KeyboardMessage
partSubscribers (Keyboard t) = do partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
@ -54,24 +55,24 @@ instance Participant Keyboard UserData where
partUnSubscribe (Keyboard t) = generalUnSubscribe t partUnSubscribe (Keyboard t) = generalUnSubscribe t
instance SDLSubsystem Keyboard UserData where instance SDLSubsystem Keyboard where
consumeSDLEvents = consumeSDLKeyboardEvents consumeSDLEvents = consumeSDLKeyboardEvents
generalSubscribe generalSubscribe
:: TVar [(UUID, msg -> Affection UserData ())] :: TVar [(UUID, msg -> Affection ())]
-> (msg -> Affection UserData ()) -> (msg -> Affection ())
-> Affection UserData UUID -> Affection UUID
generalSubscribe t funct = do generalSubscribe t funct = do
uuid <- genUUID uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid return uuid
generalUnSubscribe generalUnSubscribe
:: TVar [(UUID, msg -> Affection UserData ())] :: TVar [(UUID, msg -> Affection ())]
-> UUID -> UUID
-> Affection UserData () -> Affection ()
generalUnSubscribe t uuid = generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where where
filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p filterMsg (u, _) p = u /= p