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.Monad.IO.Class (liftIO)
import Control.Monad (when)
import Control.DeepSeq (deepseq)

import Data.Matrix as M
import qualified Data.Set as S

import System.Random (randomRIO)

import NanoVG hiding (V2(..))

import Linear

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: example01"
        , windowConfig = SDL.defaultWindow
          { SDL.windowOpenGL = Just SDL.defaultOpenGL
            { SDL.glProfile = SDL.Core SDL.Normal 3 3
            }
          , SDL.windowInitialSize = SDL.V2 600 600
          , SDL.windowResizable = True
          }
        , 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
    , foodMat = fromList 60 60 (repeat 10)
    , timeMat = M.zero 60 60
    , nano = nanoCtx
    , lastUpdate = 0
    }

pre :: Affection UserData ()
pre = do
  sd <- getAffection
  _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
  _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
  _ <- partSubscribe (subKeyboard $ subsystems sd) showFPS
  _ <- partSubscribe (subWindow   $ subsystems sd) exitOnWindowClose
  _ <- partSubscribe (subWindow   $ subsystems sd) windowResize
  now <- getElapsedTime
  putAffection sd
    { lastUpdate = floor now
    }

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 -> reload
    _ -> return ()

reload :: Affection UserData ()
reload = do
  ud <- getAffection
  now <- getElapsedTime
  randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
  let fullMatrix = fromList 60 60 randList
  putAffection ud
    { lifeMat = fullMatrix
    , foodMat = fromList 60 60 (repeat 10)
    , timeMat = M.zero 60 60
    , lastUpdate = floor now
    }

showFPS :: KeyboardMessage -> Affection UserData ()
showFPS (MsgKeyboardEvent _ _ _ _ sym) =
  case SDL.keysymKeycode sym of
    SDL.KeycodeF -> do
      dt <- getDelta
      liftIO $ logIO A.Debug $ "FPS: " ++ show (1 / dt)
    _ -> return ()

exitOnWindowClose :: WindowMessage -> Affection UserData ()
exitOnWindowClose wm =
  case wm of
    MsgWindowClose _ _ -> do
      liftIO $ logIO A.Debug "I heard another one..."
      quit
    _ -> return ()

windowResize :: WindowMessage -> Affection UserData ()
windowResize msg = case msg of
  (MsgWindowResize _ _ (V2 w h)) -> do
    liftIO $ logIO A.Debug "Window resized"
    let nw = floor (fromIntegral h)
        dw = floor ((fromIntegral w - fromIntegral nw) / 2)
    GL.viewport $= (GL.Position dw 0, GL.Size nw h)
  _ -> 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
  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 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud)
            <->
            submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud)
          | x == 1 && y == 60 =
            submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud)
            <->
            submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud)
          | x == 60 && y == 1 =
            submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud)
            <->
            submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud)
          | x == 60 && y == 60 =
            submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud)
            <->
            submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud)
          | x == 1 =
            submatrix (y - 1) (y + 1) 60 60 (lifeMat ud)
            <|>
            submatrix (y - 1) (y + 1) 1 2 (lifeMat ud)
          | y == 1 =
            submatrix 60 60 (x - 1) (x + 1) (lifeMat ud)
            <->
            submatrix 1 2 (x - 1) (x + 1) (lifeMat ud)
          | x == 60 =
            submatrix (y - 1) (y + 1) 59 60 (lifeMat ud)
            <|>
            submatrix (y - 1) (y + 1) 1 1 (lifeMat ud)
          | y == 60 =
            submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud)
            <->
            submatrix 1 1 (x - 1) (x + 1) (lifeMat ud)
          | otherwise =
            submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud)
        life = countLife subm
    if lifeMat ud M.! (y, x) == 1
    then if life == 2 || life == 3 && foodMat ud M.! (y, x) > 0
      then return (1, (foodMat ud M.! (y, x)) - 1, 0)
      else return (0, foodMat ud M.! (y, x), 1)
    else if life == 3 && foodMat ud M.! (y, x) > 0
      then return (1, (foodMat ud M.! (y, x)) - 1, 0)
      else return
        ( 0
        , if timeMat ud M.! (y, x) > 10
          then min 10 ((foodMat ud M.! (y, x)) + 1)
          else foodMat ud M.! (y, x)
        , timeMat ud M.! (y, x) + 1
        )
    ) [0..3599]
  let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
  let newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList)
  let newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
  if newLifeMat == M.zero 60 60
  then
    reload
  else
    putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud)
      { lifeMat = newLifeMat
      , foodMat = newFoodMat
      , timeMat = newTimeMat
      -- , lastUpdate = floor now
      }

countLife :: Matrix Word -> Word
countLife mat = res - (mat M.! (2, 2))
  where
    res = foldr (flip (+)) 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 `mod` 60
          y = coord `div` 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
        fillColor ctx (rgba 255 255 255 255)
      else
        fillColor ctx (rgba 0 (fromIntegral $ 25 * (foodMat ud M.! (x+1, y+1))) 0 255)
      fill ctx
      ) [0..3599]
    restore (nano ud)
    endFrame (nano ud)

clean _ = return ()