make example01 affectionate and working
This commit is contained in:
parent
9ac25d5fca
commit
a7eac3e392
2 changed files with 100 additions and 101 deletions
|
|
@ -10,7 +10,7 @@ import qualified Graphics.Rendering.OpenGL as GL
|
|||
import Control.Concurrent.STM
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad (when)
|
||||
import Control.Monad
|
||||
import Control.DeepSeq (deepseq)
|
||||
|
||||
import Data.Matrix as M
|
||||
|
|
@ -60,7 +60,7 @@ main = do
|
|||
, SDL.Windowed
|
||||
)
|
||||
]
|
||||
}
|
||||
} :: AffectionConfig UserData
|
||||
withAffection conf
|
||||
|
||||
load :: IO UserData
|
||||
|
|
@ -76,7 +76,7 @@ load = do
|
|||
-- logIO A.Debug $ prettyMatrix fullMatrix
|
||||
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())])
|
||||
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())])
|
||||
step <- NewMVar True
|
||||
step <- newMVar True
|
||||
(\life food time -> UserData
|
||||
{ subsystems = Subsystems
|
||||
(Window empty1)
|
||||
|
|
@ -94,50 +94,45 @@ load = do
|
|||
|
||||
pre :: UserData -> Affection ()
|
||||
pre ud = do
|
||||
_ <- partSubscribe (subKeyboard $ subsystems sd) (exitOnEsc (doNextStep ud))
|
||||
_ <- partSubscribe (subKeyboard $ subsystems sd) (reloadOnR ud)
|
||||
_ <- partSubscribe (subKeyboard $ subsystems sd) showFPS
|
||||
_ <- partSubscribe (subKeyboard $ subsystems sd) toggleFullScreen
|
||||
_ <- partSubscribe (subWindow $ subsystems sd) exitOnWindowClose
|
||||
_ <- partSubscribe (subWindow $ subsystems sd) (fitViewport (600/600))
|
||||
now <- getElapsedTime
|
||||
putAffection sd
|
||||
void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud))
|
||||
void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud)
|
||||
void $ partSubscribe (subKeyboard $ subsystems ud) showFPS
|
||||
void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen
|
||||
void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud))
|
||||
void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600))
|
||||
|
||||
toggleFullScreen :: KeyboardMessage -> Affection UserData ()
|
||||
toggleFullScreen :: KeyboardMessage -> Affection ()
|
||||
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
|
||||
| otherwise = return ()
|
||||
toggleFullScreen _ = return ()
|
||||
|
||||
exitOnEsc :: KeyboardMessage -> Affection UserData ()
|
||||
exitOnEsc (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
|
||||
exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection ()
|
||||
exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
|
||||
case SDL.keysymKeycode sym of
|
||||
SDL.KeycodeEscape -> do
|
||||
liftIO $ logIO A.Debug "Yo dog I heard..."
|
||||
quit
|
||||
void $ liftIO $ swapMVar step False
|
||||
_ -> return ()
|
||||
exitOnEsc _ = return ()
|
||||
exitOnEsc _ _ = return ()
|
||||
|
||||
reloadOnR :: KeyboardMessage -> Affection UserData ()
|
||||
reloadOnR (MsgKeyboardEvent _ _ _ _ sym) =
|
||||
reloadOnR :: UserData -> KeyboardMessage -> Affection ()
|
||||
reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) =
|
||||
case SDL.keysymKeycode sym of
|
||||
SDL.KeycodeR -> reload
|
||||
SDL.KeycodeR -> reload ud
|
||||
_ -> return ()
|
||||
reloadOnR _ = return ()
|
||||
reloadOnR _ _ = return ()
|
||||
|
||||
reload :: Affection UserData ()
|
||||
reload = do
|
||||
ud <- getAffection
|
||||
reload :: UserData -> Affection ()
|
||||
reload ud = do
|
||||
now <- getElapsedTime
|
||||
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
|
||||
let fullMatrix = fromList 60 60 randList
|
||||
putAffection ud
|
||||
{ lifeMat = fullMatrix
|
||||
, foodMat = fromList 60 60 (repeat 10)
|
||||
, timeMat = M.zero 60 60
|
||||
}
|
||||
void $ liftIO $ swapMVar (lifeMat ud) fullMatrix
|
||||
void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat 10))
|
||||
void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60)
|
||||
|
||||
showFPS :: KeyboardMessage -> Affection UserData ()
|
||||
showFPS :: KeyboardMessage -> Affection ()
|
||||
showFPS (MsgKeyboardEvent _ _ _ _ sym) =
|
||||
case SDL.keysymKeycode sym of
|
||||
SDL.KeycodeF -> do
|
||||
|
|
@ -146,84 +141,87 @@ showFPS (MsgKeyboardEvent _ _ _ _ sym) =
|
|||
_ -> return ()
|
||||
showFPS _ = return ()
|
||||
|
||||
exitOnWindowClose :: WindowMessage -> Affection UserData ()
|
||||
exitOnWindowClose wm =
|
||||
exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
|
||||
exitOnWindowClose step wm =
|
||||
case wm of
|
||||
MsgWindowClose _ _ -> do
|
||||
liftIO $ logIO A.Debug "I heard another one..."
|
||||
quit
|
||||
void $ liftIO $ swapMVar step False
|
||||
_ -> return ()
|
||||
exitOnWindowClose _ = return ()
|
||||
exitOnWindowClose _ _ = return ()
|
||||
|
||||
handle :: [SDL.EventPayload] -> Affection UserData ()
|
||||
handle es = do
|
||||
(Subsystems a b) <- subsystems <$> getAffection
|
||||
handle :: UserData -> [SDL.EventPayload] -> Affection ()
|
||||
handle ud es = do
|
||||
let (Subsystems a b) = subsystems ud
|
||||
_ <- consumeSDLEvents a =<< consumeSDLEvents b es
|
||||
return ()
|
||||
|
||||
update :: Double -> Affection UserData ()
|
||||
update _ = do
|
||||
ud <- getAffection
|
||||
update :: UserData -> Double -> Affection ()
|
||||
update ud dt = do
|
||||
-- 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
|
||||
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 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 =
|
||||
(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 =
|
||||
(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 =
|
||||
(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 =
|
||||
(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 =
|
||||
(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 =
|
||||
(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 =
|
||||
(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 =
|
||||
(submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud))
|
||||
(submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife)
|
||||
life = countLife subm
|
||||
ret
|
||||
| life == 0 && lifeMat ud M.! (y, x) == 0 =
|
||||
| life == 0 && pastLife M.! (y, x) == 0 =
|
||||
( 0
|
||||
, if timeMat ud M.! (y, x) >= 10
|
||||
then min 10 (foodMat ud M.! (y, x) + 1)
|
||||
else min 10 (foodMat ud M.! (y, x))
|
||||
, timeMat ud M.! (y, x) + 1
|
||||
, if pastTime M.! (y, x) >= 10
|
||||
then min 10 (pastFood M.! (y, x) + 1)
|
||||
else min 10 (pastFood M.! (y, x))
|
||||
, pastTime M.! (y, x) + 1
|
||||
)
|
||||
| otherwise = (1, 1, 1)
|
||||
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), 0)
|
||||
else if life == 3 && foodMat ud M.! (y, x) > 0
|
||||
then return (1, (foodMat ud M.! (y, x)) - 1, 0)
|
||||
if pastLife M.! (y, x) == 1
|
||||
then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0
|
||||
then return (1, (pastFood M.! (y, x)) - 1, 0)
|
||||
else return (0, pastFood M.! (y, x), 0)
|
||||
else if life == 3 && pastFood M.! (y, x) > 0
|
||||
then return (1, (pastFood 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 min 10 (foodMat ud M.! (y, x))
|
||||
, timeMat ud M.! (y, x) + 1
|
||||
, if pastTime M.! (y, x) > 10
|
||||
then min 10 ((pastFood M.! (y, x)) + 1)
|
||||
else min 10 (pastFood M.! (y, x))
|
||||
, pastTime M.! (y, x) + 1
|
||||
)
|
||||
) [0..3599]
|
||||
let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
|
||||
|
|
@ -231,22 +229,22 @@ update _ = do
|
|||
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
|
||||
}
|
||||
reload ud
|
||||
else do
|
||||
((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ())
|
||||
void $ liftIO $ swapMVar (lifeMat ud) newLifeMat
|
||||
void $ liftIO $ swapMVar (timeMat ud) newTimeMat
|
||||
-- void $ liftIO $ swapMVar (foodMat ud) newFoodMat
|
||||
|
||||
countLife :: Matrix Word -> Word
|
||||
countLife mat = res - (mat M.! (2, 2))
|
||||
where
|
||||
res = foldr (flip (+)) 0 mat
|
||||
|
||||
draw :: Affection UserData ()
|
||||
draw = do
|
||||
ud <- getAffection
|
||||
draw :: UserData -> Affection ()
|
||||
draw ud = do
|
||||
life <- liftIO $ readMVar (lifeMat ud)
|
||||
food <- liftIO $ readMVar (foodMat ud)
|
||||
liftIO $ do
|
||||
beginFrame (nano ud) 600 600 1
|
||||
save (nano ud)
|
||||
|
|
@ -254,7 +252,7 @@ draw = do
|
|||
let x = coord `mod` 60
|
||||
y = coord `div` 60
|
||||
ctx = nano ud
|
||||
mult = lifeMat ud M.! (x + 1, y + 1)
|
||||
mult = life M.! (x + 1, y + 1)
|
||||
-- logIO A.Debug $ show mult
|
||||
beginPath ctx
|
||||
rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
|
||||
|
|
@ -262,7 +260,7 @@ draw = do
|
|||
then
|
||||
fillColor ctx (rgba 255 255 255 255)
|
||||
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
|
||||
) [0..3599]
|
||||
restore (nano ud)
|
||||
|
|
|
|||
|
|
@ -10,14 +10,15 @@ import Data.Matrix as M
|
|||
import NanoVG
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
data UserData = UserData
|
||||
{ lifeMat :: Matrix Word
|
||||
, foodMat :: Matrix Word
|
||||
, timeMat :: Matrix Word
|
||||
{ lifeMat :: MVar (Matrix Word)
|
||||
, foodMat :: MVar (Matrix Word)
|
||||
, timeMat :: MVar (Matrix Word)
|
||||
, subsystems :: Subsystems
|
||||
, nano :: Context
|
||||
, doNextStep :: MVar Bool
|
||||
}
|
||||
|
||||
data Subsystems = Subsystems
|
||||
|
|
@ -25,12 +26,12 @@ data Subsystems = Subsystems
|
|||
, 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
|
||||
type Mesg Types.Window UserData = WindowMessage
|
||||
instance Participant Types.Window where
|
||||
type Mesg Types.Window = WindowMessage
|
||||
|
||||
partSubscribers (Window t) = do
|
||||
subTups <- liftIO $ readTVarIO t
|
||||
|
|
@ -40,11 +41,11 @@ instance Participant Types.Window UserData where
|
|||
|
||||
partUnSubscribe (Window t) = generalUnSubscribe t
|
||||
|
||||
instance SDLSubsystem Types.Window UserData where
|
||||
instance SDLSubsystem Types.Window where
|
||||
consumeSDLEvents = consumeSDLWindowEvents
|
||||
|
||||
instance Participant Keyboard UserData where
|
||||
type Mesg Keyboard UserData = KeyboardMessage
|
||||
instance Participant Keyboard where
|
||||
type Mesg Keyboard = KeyboardMessage
|
||||
|
||||
partSubscribers (Keyboard t) = do
|
||||
subTups <- liftIO $ readTVarIO t
|
||||
|
|
@ -54,24 +55,24 @@ instance Participant Keyboard UserData where
|
|||
|
||||
partUnSubscribe (Keyboard t) = generalUnSubscribe t
|
||||
|
||||
instance SDLSubsystem Keyboard UserData where
|
||||
instance SDLSubsystem Keyboard where
|
||||
consumeSDLEvents = consumeSDLKeyboardEvents
|
||||
|
||||
generalSubscribe
|
||||
:: TVar [(UUID, msg -> Affection UserData ())]
|
||||
-> (msg -> Affection UserData ())
|
||||
-> Affection UserData UUID
|
||||
:: TVar [(UUID, msg -> Affection ())]
|
||||
-> (msg -> Affection ())
|
||||
-> Affection UUID
|
||||
generalSubscribe t funct = do
|
||||
uuid <- genUUID
|
||||
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
|
||||
return uuid
|
||||
|
||||
generalUnSubscribe
|
||||
:: TVar [(UUID, msg -> Affection UserData ())]
|
||||
:: TVar [(UUID, msg -> Affection ())]
|
||||
-> UUID
|
||||
-> Affection UserData ()
|
||||
-> Affection ()
|
||||
generalUnSubscribe t uuid =
|
||||
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
|
||||
where
|
||||
filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool
|
||||
filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
|
||||
filterMsg (u, _) p = u /= p
|
||||
|
|
|
|||
Loading…
Reference in a new issue