{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ForeignFunctionInterface #-} import Affection as A import qualified SDL import Control.Concurrent.STM import Control.Monad.IO.Class (liftIO) import Control.Monad (when) import Data.Matrix as M import qualified Data.Set as S import System.Random (randomRIO) import NanoVG import Foreign.C.Types (CInt(..)) -- internal imports import Types foreign import ccall unsafe "glewInit" glewInit :: IO CInt main :: IO () main = do logIO A.Debug "Starting" let conf = AffectionConfig { initComponents = All , windowTitle = "affection: example00" , windowConfig = SDL.defaultWindow { SDL.windowOpenGL = Just SDL.defaultOpenGL { SDL.glProfile = SDL.Core SDL.Normal 3 3 } , SDL.windowInitialSize = SDL.V2 600 600 } , initScreenMode = SDL.Windowed , canvasSize = Nothing , loadState = load , preLoop = pre , eventLoop = handle , updateLoop = update , drawLoop = draw , cleanUp = clean } 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 UserData ())]) empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())]) return $ UserData { subsystems = Subsystems (Window empty1) (Keyboard empty3) , lifeMat = fullMatrix , nano = nanoCtx } pre :: Affection UserData () pre = do sd <- getAffection _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR _ <- partSubscribe (subWindow $ subsystems sd) exitOnWindowClose return () exitOnEsc :: KeyboardMessage -> Affection UserData () exitOnEsc (MsgKeyboardEvent _ _ _ _ sym) = case SDL.keysymKeycode sym of SDL.KeycodeEscape -> do liftIO $ logIO A.Debug "Yo dog I heard..." quit _ -> return () reloadOnR :: KeyboardMessage -> Affection UserData () reloadOnR (MsgKeyboardEvent _ _ _ _ sym) = case SDL.keysymKeycode sym of SDL.KeycodeR -> do ud <- getAffection randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599] let fullMatrix = fromList 60 60 randList nState <- liftIO $ load putAffection ud { lifeMat = fullMatrix } _ -> return () exitOnWindowClose :: WindowMessage -> Affection UserData () exitOnWindowClose wm = case wm of MsgWindowClose _ _ -> do liftIO $ logIO A.Debug "I heard another one..." quit _ -> return () handle :: [SDL.EventPayload] -> Affection UserData () handle es = do (Subsystems a b) <- subsystems <$> getAffection _ <- consumeSDLEvents a =<< consumeSDLEvents b es return () update :: Double -> Affection UserData () update _ = do ud <- getAffection -- when (lastUpdate ud < floor now) $ do liftIO $ logIO A.Debug "stepping life" newList <- mapM (\coord -> do let x = (coord `div` 60) + 1 y = (coord `mod` 60) + 1 subm | x == 1 && y == 1 = (submatrix 60 60 60 60 (lifeMat ud) <-> submatrix 1 2 60 60 (lifeMat ud)) <|> (submatrix 60 60 1 2 (lifeMat ud) <-> submatrix 1 2 1 2 (lifeMat ud)) | x == 1 && y == 60 = (submatrix 60 60 59 60 (lifeMat ud) <-> submatrix 1 2 59 60 (lifeMat ud)) <|> (submatrix 60 60 1 1 (lifeMat ud) <-> submatrix 1 2 1 1 (lifeMat ud)) | x == 60 && y == 1 = (submatrix 59 60 60 60 (lifeMat ud) <-> submatrix 1 1 60 60 (lifeMat ud)) <|> (submatrix 59 60 1 2 (lifeMat ud) <-> submatrix 1 1 1 2 (lifeMat ud)) | x == 60 && y == 60 = (submatrix 59 60 59 60 (lifeMat ud) <-> submatrix 1 1 59 60 (lifeMat ud)) <|> (submatrix 59 60 1 1 (lifeMat ud) <-> submatrix 1 1 1 1 (lifeMat ud)) | x == 1 = (submatrix 60 60 (y - 1) (y + 1) (lifeMat ud)) <-> (submatrix 1 2 (y - 1) (y + 1) (lifeMat ud)) | y == 1 = (submatrix (x - 1) (x + 1) 60 60 (lifeMat ud)) <|> (submatrix (x - 1) (x + 1) 1 2 (lifeMat ud)) | x == 60 = (submatrix 1 1 (y - 1) (y + 1) (lifeMat ud)) <-> (submatrix 59 60 (y - 1) (y + 1) (lifeMat ud)) | y == 60 = (submatrix (x - 1) (x + 1) 1 1 (lifeMat ud)) <|> (submatrix (x -1 ) (x + 1) 59 60 (lifeMat ud)) | otherwise = submatrix (x - 1) (x + 1) (y - 1) (y + 1) (lifeMat ud) life = countLife subm if (lifeMat ud) M.! (x, y) == 1 then if life == 2 || life == 3 then return 1 else return 0 else if life == 3 then return 1 else return 0 ) [0..3599] let newM = fromList 60 60 newList putAffection ud { lifeMat = newM } countLife :: Matrix Word -> Word countLife mat = res - (mat M.! (2, 2)) where res = foldr (\a acc -> a + acc) 0 mat draw :: Affection UserData () draw = do ud <- getAffection liftIO $ do beginFrame (nano ud) 600 600 1 save (nano ud) mapM_ (\coord -> do let x = coord `div` 60 y = coord `mod` 60 ctx = nano ud mult = lifeMat ud 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 do fillColor ctx (rgba 255 255 255 255) else do fillColor ctx (rgba 0 0 0 255) fill ctx ) [0..3599] restore (nano ud) endFrame (nano ud) clean _ = return ()