vulkan-tutorial/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 Data.String

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"
        , 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
            }
          )
          ]
        , 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
    }

pre :: Affection UserData ()
pre = do
  sd <- getAffection
  _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
  _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
  _ <- partSubscribe (subKeyboard $ subsystems sd) showFPS
  _ <- partSubscribe (subKeyboard $ subsystems sd) toggleFullScreen
  _ <- partSubscribe (subWindow   $ subsystems sd) exitOnWindowClose
  _ <- partSubscribe (subWindow   $ subsystems sd) (fitViewport (600/600))
  now <- getElapsedTime
  putAffection sd

toggleFullScreen :: KeyboardMessage -> Affection UserData ()
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
  | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
  | otherwise = return ()
toggleFullScreen _ = return ()

exitOnEsc :: KeyboardMessage -> Affection UserData ()
exitOnEsc (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
  case SDL.keysymKeycode sym of
    SDL.KeycodeEscape -> do
      liftIO $ logIO A.Debug "Yo dog I heard..."
      quit
    _ -> return ()
exitOnEsc _ = return ()

reloadOnR :: KeyboardMessage -> Affection UserData ()
reloadOnR (MsgKeyboardEvent _ _ _ _ sym) =
  case SDL.keysymKeycode sym of
    SDL.KeycodeR -> reload
    _ -> return ()
reloadOnR _ = 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
    }

showFPS :: KeyboardMessage -> Affection UserData ()
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 :: WindowMessage -> Affection UserData ()
exitOnWindowClose wm =
  case wm of
    MsgWindowClose _ _ -> do
      liftIO $ logIO A.Debug "I heard another one..."
      quit
    _ -> return ()
exitOnWindowClose _ = 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
        ret
          | life == 0 && lifeMat ud M.! (y, x) == 0 =
            ( 0
            , if timeMat ud M.! (y, x) >= 10
              then min 10 (foodMat ud M.! (y, x) + 1)
              else min 10 (foodMat ud M.! (y, x))
            , timeMat ud M.! (y, x) + 1
            )
          | otherwise = (1, 1, 1)
    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), 0)
    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 min 10 (foodMat ud M.! (y, x))
        , timeMat ud 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
  else
    putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud)
      { lifeMat = newLifeMat
      --, foodMat = newFoodMat
      , timeMat = newTimeMat
      }

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 ()