affection/examples/example02/Main.hs

254 lines
8.1 KiB
Haskell
Raw Normal View History

2018-12-26 22:19:20 +00:00
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ForeignFunctionInterface #-}
import Affection as A
import qualified SDL
import Control.Concurrent.STM
import Control.Concurrent.MVar
import Control.Monad
2018-12-26 22:19:20 +00:00
import Control.DeepSeq (deepseq)
import Data.Matrix as M
import qualified Data.Set as S
2019-10-28 16:10:56 +00:00
import Data.String
2018-12-26 22:19:20 +00:00
import System.Random (randomRIO)
import NanoVG hiding (V2(..))
import Foreign.C.Types (CInt(..))
-- internal imports
import Types
instance Affectionate UserData where
loadState = load
preLoop = pre
handleEvents = handle
update = Main.update
draw = Main.draw
cleanUp = clean
hasNextStep = liftIO . readMVar . doNextStep
2018-12-26 22:19:20 +00:00
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
maxFood :: Word
maxFood = 255
main :: IO ()
main = do
logIO A.Debug "Starting"
let conf = AffectionConfig
{ initComponents = All
, windowTitle = "affection: example01"
2019-01-30 11:00:28 +00:00
, windowConfigs =
[
( 0
, SDL.defaultWindow
2019-10-28 16:10:56 +00:00
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
2019-01-30 11:00:28 +00:00
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
, SDL.windowInitialSize = SDL.V2 600 600
, SDL.windowResizable = True
2018-12-26 22:19:20 +00:00
}
, SDL.Windowed
2019-01-30 11:00:28 +00:00
)
]
} :: AffectionConfig UserData
2018-12-26 22:19:20 +00:00
withAffection conf
load :: IO UserData
load = do
-- emptyMatrix <- zero 60 60
liftIO $ logIO A.Debug "init GLEW"
_ <- glewInit
liftIO $ logIO A.Debug "making random"
2020-05-04 11:40:57 +00:00
randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
2018-12-26 22:19:20 +00:00
liftIO $ logIO A.Debug "creating context"
nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
let fullMatrix = fromList 60 60 randList
-- logIO A.Debug $ prettyMatrix fullMatrix
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())])
2020-05-04 11:40:57 +00:00
(\life food time nextStep -> UserData
2018-12-26 22:19:20 +00:00
{ subsystems = Subsystems
(Window empty1)
(Keyboard empty3)
, lifeMat = life
, foodMat = food
, timeMat = time
2018-12-26 22:19:20 +00:00
, nano = nanoCtx
2020-05-04 11:40:57 +00:00
, doNextStep = nextStep
2018-12-26 22:19:20 +00:00
}
)
<$> newMVar fullMatrix
<*> newMVar (fromList 60 60 (repeat maxFood))
<*> newMVar (M.zero 60 60)
<*> newMVar True
2018-12-26 22:19:20 +00:00
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))
2018-12-26 22:19:20 +00:00
toggleFullScreen :: KeyboardMessage -> Affection ()
2018-12-26 22:19:20 +00:00
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
2018-12-26 22:19:20 +00:00
| otherwise = return ()
toggleFullScreen _ = return ()
exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection ()
exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
2018-12-26 22:19:20 +00:00
case SDL.keysymKeycode sym of
SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Yo dog I heard..."
void $ liftIO $ swapMVar step False
2018-12-26 22:19:20 +00:00
_ -> return ()
exitOnEsc _ _ = return ()
2018-12-26 22:19:20 +00:00
reloadOnR :: UserData -> KeyboardMessage -> Affection ()
reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) =
2018-12-26 22:19:20 +00:00
case SDL.keysymKeycode sym of
SDL.KeycodeR -> reload ud
2018-12-26 22:19:20 +00:00
_ -> return ()
reload :: UserData -> Affection ()
reload ud = do
2020-05-04 11:40:57 +00:00
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
2018-12-26 22:19:20 +00:00
let fullMatrix = fromList 60 60 randList
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)
2018-12-26 22:19:20 +00:00
showFPS :: KeyboardMessage -> Affection ()
2018-12-26 22:19:20 +00:00
showFPS (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of
SDL.KeycodeF -> do
dt <- getDelta
2019-10-28 16:10:56 +00:00
liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt))
2018-12-26 22:19:20 +00:00
_ -> return ()
exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
exitOnWindowClose step wm =
2018-12-26 22:19:20 +00:00
case wm of
MsgWindowClose _ _ -> do
liftIO $ logIO A.Debug "I heard another one..."
void $ liftIO $ swapMVar step False
2018-12-26 22:19:20 +00:00
_ -> return ()
handle :: UserData -> [SDL.EventPayload] -> Affection ()
handle ud es = do
let (Subsystems a b) = subsystems ud
2018-12-26 22:19:20 +00:00
_ <- consumeSDLEvents a =<< consumeSDLEvents b es
return ()
update :: UserData -> Double -> Affection ()
update ud _ = do
pastLife <- liftIO $ readMVar (lifeMat ud)
pastFood <- liftIO $ readMVar (foodMat ud)
pastTime <- liftIO $ readMVar (timeMat ud)
2018-12-26 22:19:20 +00:00
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 pastLife <|> submatrix 60 60 1 2 pastLife)
2018-12-26 22:19:20 +00:00
<->
(submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife)
2018-12-26 22:19:20 +00:00
| x == 1 && y == 60 =
(submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife)
2018-12-26 22:19:20 +00:00
<->
(submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife)
2018-12-26 22:19:20 +00:00
| x == 60 && y == 1 =
(submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife)
2018-12-26 22:19:20 +00:00
<->
(submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife)
2018-12-26 22:19:20 +00:00
| x == 60 && y == 60 =
(submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife)
2018-12-26 22:19:20 +00:00
<->
(submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife)
2018-12-26 22:19:20 +00:00
| x == 1 =
(submatrix (y - 1) (y + 1) 60 60 pastLife)
2018-12-26 22:19:20 +00:00
<|>
(submatrix (y - 1) (y + 1) 1 2 pastLife)
2018-12-26 22:19:20 +00:00
| y == 1 =
(submatrix 60 60 (x - 1) (x + 1) pastLife)
2018-12-26 22:19:20 +00:00
<->
(submatrix 1 2 (x - 1) (x + 1) pastLife)
2018-12-26 22:19:20 +00:00
| x == 60 =
(submatrix (y - 1) (y + 1) 59 60 pastLife)
2018-12-26 22:19:20 +00:00
<|>
(submatrix (y - 1) (y + 1) 1 1 pastLife)
2018-12-26 22:19:20 +00:00
| y == 60 =
(submatrix 59 60 (x -1 ) (x + 1) pastLife)
2018-12-26 22:19:20 +00:00
<->
(submatrix 1 1 (x - 1) (x + 1) pastLife)
2018-12-26 22:19:20 +00:00
| otherwise =
(submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife)
2018-12-26 22:19:20 +00:00
life = countLife subm
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)
2018-12-26 22:19:20 +00:00
else return
2020-05-04 11:40:57 +00:00
( 0 :: Word
, 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
2018-12-26 22:19:20 +00:00
)
) [0..3599]
let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList)
newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
if newLifeMat == M.zero 60 60
then
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
2018-12-26 22:19:20 +00:00
countLife :: Matrix Word -> Word
countLife mat = res - (mat M.! (2, 2))
where
res = foldr (flip (+)) 0 mat
draw :: UserData -> Affection ()
draw ud = liftIO $ do
pastLife <- readMVar (lifeMat ud)
pastFood <- readMVar (foodMat ud)
2018-12-26 22:19:20 +00:00
beginFrame (nano ud) 600 600 1
save (nano ud)
mapM_ (\coord -> do
let x = coord `mod` 60
y = coord `div` 60
ctx = nano ud
2020-05-04 11:40:57 +00:00
multiplicator = pastLife M.! (x + 1, y + 1)
2018-12-26 22:19:20 +00:00
-- logIO A.Debug $ show mult
beginPath ctx
rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
2020-05-04 11:40:57 +00:00
if multiplicator == 1
2018-12-26 22:19:20 +00:00
then
fillColor ctx (rgba 255 255 255 255)
else
fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (pastFood M.! (x+1, y+1))) 0 255)
2018-12-26 22:19:20 +00:00
fill ctx
) [0..3599]
restore (nano ud)
endFrame (nano ud)
2020-05-04 11:40:57 +00:00
clean :: UserData -> IO ()
2018-12-26 22:19:20 +00:00
clean _ = return ()