{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ForeignFunctionInterface #-} import Affection as A import SDL (($=)) 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 import Control.DeepSeq (deepseq) import Data.Matrix as M import qualified Data.Set as S import Data.String import System.Random (randomRIO) import NanoVG hiding (V2(..)) import Linear 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 foreign import ccall unsafe "glewInit" glewInit :: IO CInt main :: IO () main = do logIO A.Debug "Starting" let conf = AffectionConfig { initComponents = All , windowTitle = "affection: example01" , windowConfigs = [ ( 0 , SDL.defaultWindow { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL { SDL.glProfile = SDL.Core SDL.Normal 3 3 } , SDL.windowInitialSize = SDL.V2 600 600 , SDL.windowResizable = True } , SDL.Windowed ) ] } :: AffectionConfig UserData withAffection conf load :: IO UserData load = do -- emptyMatrix <- zero 60 60 liftIO $ logIO A.Debug "init GLEW" _ <- glewInit liftIO $ logIO A.Debug "making random" randList <- mapM (\_ -> randomRIO (0,1)) [0..3599] 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 ())]) step <- newMVar True (\life food time -> UserData { subsystems = Subsystems (Window empty1) (Keyboard empty3) , lifeMat = life , foodMat = food , timeMat = time , nano = nanoCtx , doNextStep = step } ) <$> newMVar fullMatrix <*> (newMVar (fromList 60 60 (repeat 10))) <*> (newMVar (M.zero 60 60)) 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 () toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym) | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen | otherwise = return () toggleFullScreen _ = return () 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..." void $ liftIO $ swapMVar step False _ -> return () exitOnEsc _ _ = return () reloadOnR :: UserData -> KeyboardMessage -> Affection () reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) = case SDL.keysymKeycode sym of SDL.KeycodeR -> reload ud _ -> return () reloadOnR _ _ = return () reload :: UserData -> Affection () reload ud = do now <- getElapsedTime randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599] let fullMatrix = fromList 60 60 randList 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 () showFPS (MsgKeyboardEvent _ _ _ _ sym) = case SDL.keysymKeycode sym of SDL.KeycodeF -> do dt <- getDelta liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt)) _ -> return () showFPS _ = return () exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection () exitOnWindowClose step wm = case wm of MsgWindowClose _ _ -> do liftIO $ logIO A.Debug "I heard another one..." void $ liftIO $ swapMVar step False _ -> return () exitOnWindowClose _ _ = return () handle :: UserData -> [SDL.EventPayload] -> Affection () handle ud es = do let (Subsystems a b) = subsystems ud _ <- consumeSDLEvents a =<< consumeSDLEvents b es return () 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 pastLife <|> submatrix 60 60 1 2 pastLife) <-> (submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife) | x == 1 && y == 60 = (submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife) <-> (submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife) | x == 60 && y == 1 = (submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife) <-> (submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife) | x == 60 && y == 60 = (submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife) <-> (submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife) | x == 1 = (submatrix (y - 1) (y + 1) 60 60 pastLife) <|> (submatrix (y - 1) (y + 1) 1 2 pastLife) | y == 1 = (submatrix 60 60 (x - 1) (x + 1) pastLife) <-> (submatrix 1 2 (x - 1) (x + 1) pastLife) | x == 60 = (submatrix (y - 1) (y + 1) 59 60 pastLife) <|> (submatrix (y - 1) (y + 1) 1 1 pastLife) | y == 60 = (submatrix 59 60 (x -1 ) (x + 1) pastLife) <-> (submatrix 1 1 (x - 1) (x + 1) pastLife) | otherwise = (submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife) life = countLife subm ret | life == 0 && pastLife M.! (y, x) == 0 = ( 0 , 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 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 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) 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 countLife :: Matrix Word -> Word countLife mat = res - (mat M.! (2, 2)) where res = foldr (flip (+)) 0 mat 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) mapM_ (\coord -> do let x = coord `mod` 60 y = coord `div` 60 ctx = nano ud mult = life M.! (x + 1, y + 1) -- logIO A.Debug $ show mult beginPath ctx rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10 if mult == 1 then fillColor ctx (rgba 255 255 255 255) else fillColor ctx (rgba 0 (fromIntegral $ 25 * (food M.! (x+1, y+1))) 0 255) fill ctx ) [0..3599] restore (nano ud) endFrame (nano ud) clean _ = return ()