251 lines
7.7 KiB
Haskell
251 lines
7.7 KiB
Haskell
{-# 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 ()
|