affection/examples/example01/Main.hs

252 lines
7.7 KiB
Haskell
Raw Normal View History

2017-12-28 15:56:49 +00:00
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ForeignFunctionInterface #-}
import Affection as A
2017-12-29 14:03:21 +00:00
import SDL (($=))
2017-12-28 15:56:49 +00:00
import qualified SDL
2017-12-29 14:03:21 +00:00
import qualified Graphics.Rendering.OpenGL as GL
2017-12-28 15:56:49 +00:00
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
import Control.Monad (when)
2017-12-29 14:03:21 +00:00
import Control.DeepSeq (deepseq)
2017-12-28 15:56:49 +00:00
import Data.Matrix as M
import qualified Data.Set as S
import System.Random (randomRIO)
2017-12-29 14:03:21 +00:00
import NanoVG hiding (V2(..))
import Linear
2017-12-28 15:56:49 +00:00
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
2017-12-29 14:03:21 +00:00
, windowTitle = "affection: example01"
2017-12-28 15:56:49 +00:00
, windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
, SDL.windowInitialSize = SDL.V2 600 600
2017-12-29 14:03:21 +00:00
, SDL.windowResizable = True
2017-12-28 15:56:49 +00:00
}
, 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
2017-12-29 14:03:21 +00:00
, foodMat = fromList 60 60 (repeat 10)
, timeMat = M.zero 60 60
2017-12-28 15:56:49 +00:00
, nano = nanoCtx
2017-12-29 14:03:21 +00:00
, lastUpdate = 0
2017-12-28 15:56:49 +00:00
}
pre :: Affection UserData ()
pre = do
sd <- getAffection
_ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
_ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
2017-12-29 14:03:21 +00:00
_ <- partSubscribe (subKeyboard $ subsystems sd) showFPS
2017-12-28 15:56:49 +00:00
_ <- partSubscribe (subWindow $ subsystems sd) exitOnWindowClose
2017-12-29 14:03:21 +00:00
_ <- partSubscribe (subWindow $ subsystems sd) windowResize
now <- getElapsedTime
putAffection sd
{ lastUpdate = floor now
}
2017-12-28 15:56:49 +00:00
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
2017-12-29 14:03:21 +00:00
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)
2017-12-28 15:56:49 +00:00
_ -> return ()
exitOnWindowClose :: WindowMessage -> Affection UserData ()
exitOnWindowClose wm =
case wm of
MsgWindowClose _ _ -> do
liftIO $ logIO A.Debug "I heard another one..."
quit
_ -> return ()
2017-12-29 14:03:21 +00:00
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 ()
2017-12-28 15:56:49 +00:00
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
2018-09-25 14:10:36 +00:00
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
}
2017-12-28 15:56:49 +00:00
countLife :: Matrix Word -> Word
countLife mat = res - (mat M.! (2, 2))
where
2018-09-25 14:10:36 +00:00
res = foldr (flip (+)) 0 mat
2017-12-28 15:56:49 +00:00
draw :: Affection UserData ()
draw = do
ud <- getAffection
liftIO $ do
beginFrame (nano ud) 600 600 1
save (nano ud)
mapM_ (\coord -> do
2017-12-29 14:03:21 +00:00
let x = coord `mod` 60
y = coord `div` 60
2017-12-28 15:56:49 +00:00
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
2018-09-25 14:10:36 +00:00
if mult == 1
then
2017-12-28 15:56:49 +00:00
fillColor ctx (rgba 255 255 255 255)
2018-09-25 14:10:36 +00:00
else
2017-12-29 14:03:21 +00:00
fillColor ctx (rgba 0 (fromIntegral $ 25 * (foodMat ud M.! (x+1, y+1))) 0 255)
2017-12-28 15:56:49 +00:00
fill ctx
) [0..3599]
restore (nano ud)
endFrame (nano ud)
clean _ = return ()