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

made example02 affectionate and working!

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

207
examples/example02/Main.hs
View file

@ -8,8 +8,9 @@ import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import Control.Concurrent.STM import Control.Concurrent.STM
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
@ -28,6 +29,15 @@ import Foreign.C.Types (CInt(..))
import Types 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" foreign import ccall unsafe "glewInit"
glewInit :: IO CInt glewInit :: IO CInt
@ -50,17 +60,10 @@ main = do
, SDL.windowInitialSize = SDL.V2 600 600 , SDL.windowInitialSize = SDL.V2 600 600
, SDL.windowResizable = True , SDL.windowResizable = True
} }
, SDL.Windowed
) )
] ]
, initScreenMode = SDL.Windowed } :: AffectionConfig UserData
, canvasSize = Nothing
, loadState = load
, preLoop = pre
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = clean
}
withAffection conf withAffection conf
load :: IO UserData load :: IO UserData
@ -74,65 +77,64 @@ load = do
nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug]) nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
let fullMatrix = fromList 60 60 randList let fullMatrix = fromList 60 60 randList
-- logIO A.Debug $ prettyMatrix fullMatrix -- logIO A.Debug $ prettyMatrix fullMatrix
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection UserData ())]) empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())]) empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())])
return $ UserData (\life food time break -> UserData
{ subsystems = Subsystems { subsystems = Subsystems
(Window empty1) (Window empty1)
(Keyboard empty3) (Keyboard empty3)
, lifeMat = fullMatrix , lifeMat = life
, foodMat = fromList 60 60 (repeat maxFood) , foodMat = food
, timeMat = M.zero 60 60 , timeMat = time
, nano = nanoCtx , nano = nanoCtx
, doNextStep = break
} }
)
<$> newMVar fullMatrix
<*> newMVar (fromList 60 60 (repeat maxFood))
<*> newMVar (M.zero 60 60)
<*> newMVar True
pre :: Affection UserData () pre :: UserData -> Affection ()
pre = do pre ud = do
sd <- getAffection void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud))
_ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud)
_ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR void $ partSubscribe (subKeyboard $ subsystems ud) showFPS
_ <- partSubscribe (subKeyboard $ subsystems sd) showFPS void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen
_ <- partSubscribe (subKeyboard $ subsystems sd) toggleFullScreen void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud))
_ <- partSubscribe (subWindow $ subsystems sd) exitOnWindowClose void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600))
_ <- partSubscribe (subWindow $ subsystems sd) (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 0
| 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
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 maxFood))
, foodMat = fromList 60 60 (repeat maxFood) 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
@ -141,84 +143,86 @@ 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 _ = do
ud <- getAffection 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 maxFood ((foodMat ud M.! (y, x)) + 1) then min maxFood ((pastFood M.! (y, x)) + 1)
else min maxFood (foodMat ud M.! (y, x)) else min maxFood (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)
@ -226,30 +230,29 @@ 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 = liftIO $ do
ud <- getAffection pastLife <- readMVar (lifeMat ud)
liftIO $ do pastFood <- readMVar (foodMat ud)
beginFrame (nano ud) 600 600 1 beginFrame (nano ud) 600 600 1
save (nano ud) save (nano ud)
mapM_ (\coord -> do mapM_ (\coord -> 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 = pastLife 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
@ -257,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 $ (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 fill ctx
) [0..3599] ) [0..3599]
restore (nano ud) restore (nano ud)

37
examples/example02/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