affection/examples/example01/Main.hs

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