nek0/affection
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

game of life works now

Browse source
This commit is contained in:
nek0 2017-12-29 15:03:21 +01:00
parent 93140bd713
commit e83a36910a
3 changed files with 134 additions and 68 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
affection.cabal
View file

@ -148,5 +148,6 @@ executable example01
, linear , linear
, matrix , matrix
, nanovg , nanovg
, deepseq
else else
buildable: False buildable: False

198
examples/example01/Main.hs
View file

@ -3,18 +3,23 @@
{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ForeignFunctionInterface #-}
import Affection as A import Affection as A
import SDL (($=))
import qualified SDL import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad (when) import Control.Monad (when)
import Control.DeepSeq (deepseq)
import Data.Matrix as M import Data.Matrix as M
import qualified Data.Set as S import qualified Data.Set as S
import System.Random (randomRIO) import System.Random (randomRIO)
import NanoVG import NanoVG hiding (V2(..))
import Linear
import Foreign.C.Types (CInt(..)) import Foreign.C.Types (CInt(..))
@ -30,12 +35,13 @@ main = do
logIO A.Debug "Starting" logIO A.Debug "Starting"
let conf = AffectionConfig let conf = AffectionConfig
{ initComponents = All { initComponents = All
, windowTitle = "affection: example00" , windowTitle = "affection: example01"
, windowConfig = SDL.defaultWindow , windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL { SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3 { SDL.glProfile = SDL.Core SDL.Normal 3 3
} }
, SDL.windowInitialSize = SDL.V2 600 600 , SDL.windowInitialSize = SDL.V2 600 600
, SDL.windowResizable = True
} }
, initScreenMode = SDL.Windowed , initScreenMode = SDL.Windowed
, canvasSize = Nothing , canvasSize = Nothing
@ -66,7 +72,10 @@ load = do
(Window empty1) (Window empty1)
(Keyboard empty3) (Keyboard empty3)
, lifeMat = fullMatrix , lifeMat = fullMatrix
, foodMat = fromList 60 60 (repeat 10)
, timeMat = M.zero 60 60
, nano = nanoCtx , nano = nanoCtx
, lastUpdate = 0
} }
pre :: Affection UserData () pre :: Affection UserData ()
@ -74,8 +83,13 @@ pre = do
sd <- getAffection sd <- getAffection
_ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
_ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
_ <- partSubscribe (subKeyboard $ subsystems sd) showFPS
_ <- partSubscribe (subWindow $ subsystems sd) exitOnWindowClose _ <- partSubscribe (subWindow $ subsystems sd) exitOnWindowClose
return () _ <- partSubscribe (subWindow $ subsystems sd) windowResize
now <- getElapsedTime
putAffection sd
{ lastUpdate = floor now
}
exitOnEsc :: KeyboardMessage -> Affection UserData () exitOnEsc :: KeyboardMessage -> Affection UserData ()
exitOnEsc (MsgKeyboardEvent _ _ _ _ sym) = exitOnEsc (MsgKeyboardEvent _ _ _ _ sym) =
@ -88,14 +102,28 @@ exitOnEsc (MsgKeyboardEvent _ _ _ _ sym) =
reloadOnR :: KeyboardMessage -> Affection UserData () reloadOnR :: KeyboardMessage -> Affection UserData ()
reloadOnR (MsgKeyboardEvent _ _ _ _ sym) = reloadOnR (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of case SDL.keysymKeycode sym of
SDL.KeycodeR -> do SDL.KeycodeR -> reload
ud <- getAffection _ -> return ()
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
let fullMatrix = fromList 60 60 randList reload :: Affection UserData ()
nState <- liftIO $ load reload = do
putAffection ud ud <- getAffection
{ lifeMat = fullMatrix 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 () _ -> return ()
exitOnWindowClose :: WindowMessage -> Affection UserData () exitOnWindowClose :: WindowMessage -> Affection UserData ()
@ -106,6 +134,15 @@ exitOnWindowClose wm =
quit quit
_ -> return () _ -> 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 :: [SDL.EventPayload] -> Affection UserData ()
handle es = do handle es = do
(Subsystems a b) <- subsystems <$> getAffection (Subsystems a b) <- subsystems <$> getAffection
@ -115,64 +152,89 @@ handle es = do
update :: Double -> Affection UserData () update :: Double -> Affection UserData ()
update _ = do update _ = do
ud <- getAffection ud <- getAffection
-- when (lastUpdate ud < floor now) $ do -- now <- getElapsedTime
liftIO $ logIO A.Debug "stepping life" when (True) $ do
newList <- mapM (\coord -> do newList <- mapM (\coord -> do
let x = (coord `div` 60) + 1 let x = (coord `mod` 60) + 1
y = (coord `mod` 60) + 1 y = (coord `div` 60) + 1
subm subm
| x == 1 && y == 1 = | x == 1 && y == 1 =
(submatrix 60 60 60 60 (lifeMat ud) <-> submatrix 1 2 60 60 (lifeMat ud)) (submatrix 60 60 60 60 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud))
<|> <->
(submatrix 60 60 1 2 (lifeMat ud) <-> submatrix 1 2 1 2 (lifeMat ud)) (submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud))
| x == 1 && y == 60 = | x == 1 && y == 60 =
(submatrix 60 60 59 60 (lifeMat ud) <-> submatrix 1 2 59 60 (lifeMat ud)) (submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud))
<|> <->
(submatrix 60 60 1 1 (lifeMat ud) <-> submatrix 1 2 1 1 (lifeMat ud)) (submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud))
| x == 60 && y == 1 = | x == 60 && y == 1 =
(submatrix 59 60 60 60 (lifeMat ud) <-> submatrix 1 1 60 60 (lifeMat ud)) (submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud))
<|> <->
(submatrix 59 60 1 2 (lifeMat ud) <-> submatrix 1 1 1 2 (lifeMat ud)) (submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud))
| x == 60 && y == 60 = | x == 60 && y == 60 =
(submatrix 59 60 59 60 (lifeMat ud) <-> submatrix 1 1 59 60 (lifeMat ud)) (submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud))
<|> <->
(submatrix 59 60 1 1 (lifeMat ud) <-> submatrix 1 1 1 1 (lifeMat ud)) (submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud))
| x == 1 = | x == 1 =
(submatrix 60 60 (y - 1) (y + 1) (lifeMat ud)) (submatrix (y - 1) (y + 1) 60 60 (lifeMat ud))
<-> <|>
(submatrix 1 2 (y - 1) (y + 1) (lifeMat ud)) (submatrix (y - 1) (y + 1) 1 2 (lifeMat ud))
| y == 1 = | y == 1 =
(submatrix (x - 1) (x + 1) 60 60 (lifeMat ud)) (submatrix 60 60 (x - 1) (x + 1) (lifeMat ud))
<|> <->
(submatrix (x - 1) (x + 1) 1 2 (lifeMat ud)) (submatrix 1 2 (x - 1) (x + 1) (lifeMat ud))
| x == 60 = | x == 60 =
(submatrix 1 1 (y - 1) (y + 1) (lifeMat ud)) (submatrix (y - 1) (y + 1) 59 60 (lifeMat ud))
<-> <|>
(submatrix 59 60 (y - 1) (y + 1) (lifeMat ud)) (submatrix (y - 1) (y + 1) 1 1 (lifeMat ud))
| y == 60 = | y == 60 =
(submatrix (x - 1) (x + 1) 1 1 (lifeMat ud)) (submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud))
<|> <->
(submatrix (x -1 ) (x + 1) 59 60 (lifeMat ud)) (submatrix 1 1 (x - 1) (x + 1) (lifeMat ud))
| otherwise = | otherwise =
submatrix (x - 1) (x + 1) (y - 1) (y + 1) (lifeMat ud) submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud)
life = countLife subm life = countLife subm
if (lifeMat ud) M.! (x, y) == 1 if (lifeMat ud) M.! (y, x) == 1
then if life == 2 || life == 3 then if life == 2 || life == 3
then return 1 then if foodMat ud M.! (y, x) > 0
else return 0 then return (1, (foodMat ud M.! (y, x)) - 1, 0)
else if life == 3 else return (0, foodMat ud M.! (y, x), 1)
then return 1 else return (0, foodMat ud M.! (y, x), 1)
else return 0 else if life == 3
) [0..3599] then if foodMat ud M.! (y, x) > 0
let newM = fromList 60 60 newList then return (1, (foodMat ud M.! (y, x)) - 1, 0)
putAffection ud else return
{ lifeMat = newM ( 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
)
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 :: Matrix Word -> Word
countLife mat = res - (mat M.! (2, 2)) countLife mat = res - (mat M.! (2, 2))
where where
res = foldr (\a acc -> a + acc) 0 mat res = foldr (\a acc -> acc + a) 0 mat
draw :: Affection UserData () draw :: Affection UserData ()
draw = do draw = do
@ -181,8 +243,8 @@ draw = do
beginFrame (nano ud) 600 600 1 beginFrame (nano ud) 600 600 1
save (nano ud) save (nano ud)
mapM_ (\coord -> do mapM_ (\coord -> do
let x = coord `div` 60 let x = coord `mod` 60
y = coord `mod` 60 y = coord `div` 60
ctx = nano ud ctx = nano ud
mult = lifeMat ud M.! (x + 1, y + 1) mult = lifeMat ud M.! (x + 1, y + 1)
-- logIO A.Debug $ show mult -- logIO A.Debug $ show mult
@ -192,7 +254,7 @@ draw = do
then do then do
fillColor ctx (rgba 255 255 255 255) fillColor ctx (rgba 255 255 255 255)
else do else do
fillColor ctx (rgba 0 0 0 255) fillColor ctx (rgba 0 (fromIntegral $ 25 * (foodMat ud M.! (x+1, y+1))) 0 255)
fill ctx fill ctx
) [0..3599] ) [0..3599]
restore (nano ud) restore (nano ud)

3
examples/example01/Types.hs
View file

@ -14,8 +14,11 @@ import Control.Monad.IO.Class (liftIO)
data UserData = UserData data UserData = UserData
{ lifeMat :: Matrix Word { lifeMat :: Matrix Word
, foodMat :: Matrix Word
, timeMat :: Matrix Word
, subsystems :: Subsystems , subsystems :: Subsystems
, nano :: Context , nano :: Context
, lastUpdate :: Int
} }
data Subsystems = Subsystems data Subsystems = Subsystems