made example02 affectionate and working!

This commit is contained in:
nek0 2020-05-04 13:06:36 +02:00
parent 8785405420
commit f52e94e82a
2 changed files with 124 additions and 120 deletions

View file

@ -8,8 +8,9 @@ import qualified SDL
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
@ -28,6 +29,15 @@ import Foreign.C.Types (CInt(..))
import Types
instance Affectionate UserData where
loadState = load
preLoop = pre
handleEvents = handle
update = Main.update
draw = Main.draw
cleanUp = clean
hasNextStep = liftIO . readMVar . doNextStep
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
@ -50,17 +60,10 @@ main = do
, SDL.windowInitialSize = SDL.V2 600 600
, SDL.windowResizable = True
}
, SDL.Windowed
)
]
, initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
, preLoop = pre
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = clean
}
} :: AffectionConfig UserData
withAffection conf
load :: IO UserData
@ -74,65 +77,64 @@ load = do
nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
let fullMatrix = fromList 60 60 randList
-- logIO A.Debug $ prettyMatrix fullMatrix
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection UserData ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())])
return $ UserData
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())])
(\life food time break -> UserData
{ subsystems = Subsystems
(Window empty1)
(Keyboard empty3)
, lifeMat = fullMatrix
, foodMat = fromList 60 60 (repeat maxFood)
, timeMat = M.zero 60 60
, lifeMat = life
, foodMat = food
, timeMat = time
, nano = nanoCtx
, doNextStep = break
}
)
<$> newMVar fullMatrix
<*> newMVar (fromList 60 60 (repeat maxFood))
<*> newMVar (M.zero 60 60)
<*> newMVar True
pre :: Affection UserData ()
pre = do
sd <- getAffection
_ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
_ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
_ <- 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
pre :: UserData -> Affection ()
pre ud = do
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
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
| 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
now <- getElapsedTime
reload :: UserData -> Affection ()
reload ud = do
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
let fullMatrix = fromList 60 60 randList
putAffection ud
{ lifeMat = fullMatrix
, foodMat = fromList 60 60 (repeat maxFood)
, timeMat = M.zero 60 60
}
void $ liftIO $ swapMVar (lifeMat ud) fullMatrix
void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat maxFood))
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
@ -141,84 +143,86 @@ 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 _ = do
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 maxFood ((foodMat ud M.! (y, x)) + 1)
else min maxFood (foodMat ud M.! (y, x))
, timeMat ud M.! (y, x) + 1
, if pastTime M.! (y, x) > 10
then min maxFood ((pastFood M.! (y, x)) + 1)
else min maxFood (pastFood M.! (y, x))
, pastTime M.! (y, x) + 1
)
) [0..3599]
let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
@ -226,30 +230,29 @@ 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
liftIO $ do
draw :: UserData -> Affection ()
draw ud = liftIO $ do
pastLife <- readMVar (lifeMat ud)
pastFood <- readMVar (foodMat ud)
beginFrame (nano ud) 600 600 1
save (nano ud)
mapM_ (\coord -> do
let x = coord `mod` 60
y = coord `div` 60
ctx = nano ud
mult = lifeMat ud M.! (x + 1, y + 1)
mult = pastLife M.! (x + 1, y + 1)
-- logIO A.Debug $ show mult
beginPath ctx
rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
@ -257,7 +260,7 @@ draw = do
then
fillColor ctx (rgba 255 255 255 255)
else
fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (foodMat ud M.! (x+1, y+1))) 0 255)
fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (pastFood M.! (x+1, y+1))) 0 255)
fill ctx
) [0..3599]
restore (nano ud)

View file

@ -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