affection/examples/example01/Main.hs

{-# 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 0
  | 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 ()