optimization

This commit is contained in:
nek0 2017-03-29 16:37:36 +02:00
parent 121c9fb120
commit 1875797cb1

View file

@ -19,7 +19,7 @@ import Foreign.Marshal.Utils
import Debug.Trace import Debug.Trace
dimension :: Int dimension :: Int
dimension = 30 dimension = 60
resolution :: Int resolution :: Int
resolution = 600 resolution = 600
@ -35,7 +35,7 @@ main = do
(CInt $ fromIntegral resolution) (CInt $ fromIntegral resolution)
} }
, canvasSize = Nothing , canvasSize = Nothing
, preLoop = loadMatrix , preLoop = loadList
, eventLoop = handle , eventLoop = handle
, updateLoop = Main.update , updateLoop = Main.update
, drawLoop = draw , drawLoop = draw
@ -48,9 +48,8 @@ data UserData = UserData
{ nodeGraph :: M.Map String G.GeglNode { nodeGraph :: M.Map String G.GeglNode
, foreground :: G.GeglBuffer , foreground :: G.GeglBuffer
, keysDown :: [SDL.Keycode] , keysDown :: [SDL.Keycode]
, matrix :: X.Matrix Bool , liveIndices :: [(Int, Int)]
, indices :: [(Int, Int)] , indices :: [(Int, Int)]
-- , cells :: [((Int, Int), M.Map String G.GeglNode)]
, cells :: [((Int, Int), Actor String)] , cells :: [((Int, Int), Actor String)]
, updateActors :: [Actor String] , updateActors :: [Actor String]
} }
@ -109,8 +108,6 @@ load = do
tempRect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" tempRect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle"
tempProps tempProps
G.gegl_node_connect_to tempRect "output" tempOver "aux" G.gegl_node_connect_to tempRect "output" tempOver "aux"
-- unless (null acc) $
-- G.gegl_node_link tempOver ((actorNodes $ snd $ head acc) M.! "over")
let tempMap = M.fromList let tempMap = M.fromList
[ ("over", tempOver) [ ("over", tempOver)
, ("rect", tempRect) , ("rect", tempRect)
@ -130,234 +127,73 @@ load = do
([] :: [((Int, Int), Actor String)]) ([] :: [((Int, Int), Actor String)])
indices indices
:: IO [((Int, Int), Actor String)] :: IO [((Int, Int), Actor String)]
-- _ <- G.gegl_node_link ((actorNodes $ snd $ last cells) M.! "over") nop
traceM "loading complete" traceM "loading complete"
return UserData return UserData
{ nodeGraph = myMap { nodeGraph = myMap
, foreground = buffer , foreground = buffer
, keysDown = [] , keysDown = []
, matrix = emptyMatrix
, indices = indices , indices = indices
, liveIndices = []
, cells = cells , cells = cells
, updateActors = [] , updateActors = []
} }
loadMatrix :: Affection UserData () loadList :: Affection UserData ()
loadMatrix = do loadList = do
!init <- liftIO $ X.fromList dimension dimension <$> MP.mapM (const (randomRIO (False, True))) [1..(dimension ^ 2)] ud@UserData{..} <- getAffection
ud <- getAffection init <- foldM (\acc coord -> do
trig <- liftIO $ randomRIO (True, False)
if trig then return (coord : acc) else return acc
) [] indices
putAffection ud putAffection ud
{ matrix = init { liveIndices = init
} }
traceM "matrix initialized"
getNeighbors :: (Int, Int) -> Affection UserData (X.Matrix Bool) getNeighbors :: (Int, Int) -> Affection UserData [(Int, Int)]
getNeighbors (row, col) getNeighbors (row, col) =
| row == 1 && col == 1 = do do
UserData{..} <- getAffection UserData{..} <- getAffection
return $ X.joinBlocks mapM (\(pr, pc) ->
( X.submatrix return (overflow(row + pr), overflow(col + pc))
dimension ) lcs
dimension where
dimension overflow x
dimension | x < 1 = dimension
matrix | x > dimension = 1
, X.submatrix | otherwise = x
dimension
dimension lcs :: [(Int, Int)]
col lcs =
(col + 1) [ (-1, -1)
matrix , (-1, 0)
, X.submatrix , (-1, 1)
row , (0, -1)
(row + 1) -- , (0, 0)
dimension , (0, 1)
dimension , (1, -1)
matrix , (1, 0)
, X.submatrix , (1, 1)
row ]
(row + 1)
col
(col + 1)
matrix
)
| row == 1 && col == dimension = do
UserData{..} <- getAffection
return $ X.joinBlocks
( X.submatrix
dimension
dimension
(col - 1)
col
matrix
, X.submatrix
dimension
dimension
1
1
matrix
, X.submatrix
row
(row + 1)
(col - 1)
col
matrix
, X.submatrix
row
(row + 1)
1
1
matrix
)
| row == dimension && col == 1 = do
UserData{..} <- getAffection
return $ X.joinBlocks
( X.submatrix
(row - 1)
row
dimension
dimension
matrix
, X.submatrix
(row - 1)
row
col
(col + 1)
matrix
, X.submatrix
1
1
dimension
dimension
matrix
, X.submatrix
1
1
col
(col + 1)
matrix
)
| row == dimension && col == dimension = do
UserData{..} <- getAffection
return $ X.joinBlocks
( X.submatrix
(row - 1)
row
(col - 1)
col
matrix
, X.submatrix
(row - 1)
row
1
1
matrix
, X.submatrix
1
1
(col - 1)
col
matrix
, X.submatrix
1
1
1
1
matrix
)
| row == 1 = do
UserData{..} <- getAffection
return $
X.submatrix
dimension
dimension
(col - 1)
(col + 1)
matrix
X.<->
X.submatrix
row
(row + 1)
(col - 1)
(col + 1)
matrix
| row == dimension = do
UserData{..} <- getAffection
return $
X.submatrix
(row - 1)
row
(col - 1)
(col + 1)
matrix
X.<->
X.submatrix
1
1
(col - 1)
(col + 1)
matrix
| col == 1 = do
UserData{..} <- getAffection
return $
X.submatrix
(row - 1)
(row + 1)
dimension
dimension
matrix
X.<|>
X.submatrix
(row - 1)
(row + 1)
col
(col + 1)
matrix
| col == dimension = do
UserData{..} <- getAffection
return $
X.submatrix
(row - 1)
(row + 1)
(col - 1)
col
matrix
X.<|>
X.submatrix
(row - 1)
(row + 1)
1
1
matrix
| otherwise = do
UserData{..} <- getAffection
return $ X.submatrix (row - 1) (row + 1) (col - 1) (col + 1) matrix
draw :: Affection UserData () draw :: Affection UserData ()
draw = do draw = do
traceM "drawing" traceM "drawing"
ud@UserData{..} <- getAffection ud@UserData{..} <- getAffection
_ <- liftIO $ MP.mapM let livingActors = catMaybes $ parMap rpar (\i -> lookup i cells) liveIndices
(\(_, a) -> G.gegl_node_disconnect (actorNodes a M.! "over") "input"
) cells
-- _ <- liftIO $ G.gegl_node_disconnect (nodeGraph M.! "nop") "input"
let livingActors = catMaybes $ map (\coord -> do
if matrix X.! coord
then lookup coord cells
else Nothing
) indices
unless (null livingActors) $ do unless (null livingActors) $ do
liftIO $ G.gegl_node_link_many $ liftIO $ G.gegl_node_link_many $
map (\a -> (actorNodes a) M.! "over") livingActors parMap rpar (\a -> (actorNodes a) M.! "over") livingActors
_ <- liftIO $ G.gegl_node_link ((actorNodes $ last livingActors) M.! "over") _ <- liftIO $ G.gegl_node_link ((actorNodes $ last livingActors) M.! "over")
(nodeGraph M.! "nop") (nodeGraph M.! "nop")
return () return ()
-- MP.mapM_ applyProperties updateActors
process (nodeGraph M.! "sink") process (nodeGraph M.! "sink")
present (G.GeglRectangle 0 0 resolution resolution) foreground True present (G.GeglRectangle 0 0 resolution resolution) foreground True
render render
Nothing Nothing
Nothing Nothing
_ <- liftIO $ MP.mapM
(\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input"
) livingActors
putAffection ud putAffection ud
{ updateActors = [] { updateActors = []
} }
@ -371,70 +207,45 @@ update dt = do
traceM $ show (1 / dt) ++ " FPS" traceM $ show (1 / dt) ++ " FPS"
traceM $ show $ keysDown ud traceM $ show $ keysDown ud
new <- MP.mapM (\coord@(row, col) -> do
neighs <- X.toList <$> getNeighbors coord relevant <- getRelevant (liveIndices ud)
if True `elem` neighs
then do new <- catMaybes <$> MP.mapM (\coord@(row, col) -> do
let !living = sum $ parMap rpar (fromBool) neighs neighs <-
if matrix ud X.! coord foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 <$>
then getNeighbors coord
if living - 1 == 2 || living - 1 == 3 let ret
then | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
return True Just coord
else do | neighs == 3 =
-- tud <- getAffection Just coord
-- let nac = updateProperties (props $ do | otherwise =
-- prop "color" $ G.RGB 0 0 0 Nothing
-- ) (fromJust $ lookup coord (cells tud)) return ret
-- putAffection tud ) relevant
-- { updateActors =
-- nac : updateActors tud
-- , cells = (coord, nac) :
-- (deleteBy (\a b -> fst a == fst b) (coord, nac) (cells tud))
-- }
return False
else
if living == 3
then do
-- tud <- getAffection
-- let nac = updateProperties (props $ do
-- prop "color" $ G.RGB 1 1 1
-- ) (fromJust $ lookup coord (cells tud))
-- putAffection tud
-- { updateActors =
-- nac : updateActors tud
-- , cells = (coord, nac) :
-- (deleteBy (\a b -> fst a == fst b) (coord, nac) (cells tud))
-- }
return True
else
return False
else
return False
) (indices ud)
ud2 <- getAffection ud2 <- getAffection
putAffection ud2 putAffection ud2
{ matrix = X.fromList dimension dimension new { liveIndices = new
} }
-- when (floor elapsed < floor (elapsed + dt)) $ do
-- new <- mapM (\coord@(col, row) -> do
-- living <- foldl (\acc b -> if b then acc + 1 else acc) 0 <$>
-- getNeighbors coord
-- if matrix ud X.! coord
-- then
-- if living == 2 || living == 3 then return $ True else return $ False
-- else
-- if living == 3 then return $ True else return $ False
-- ) (indices ud)
-- traceM $ show $ X.fromList 10 10 new
-- putAffection ud
-- { matrix = X.fromList 10 10 new
-- }
mapM_ (\code -> mapM_ (\code ->
when (code == SDL.KeycodeR) loadMatrix when (code == SDL.KeycodeR) loadList
) (keysDown ud) ) (keysDown ud)
getRelevant :: [(Int, Int)] -> Affection UserData [(Int, Int)]
getRelevant ls =
getRelevant' ls
where
getRelevant' xs = foldM (\acc x -> do
neighs <- getNeighbors x
let slice = (x : neighs)
rels = foldl (\a y ->
if y `elem` acc then a else y : a
) [] slice
return (acc ++ rels)
) [] xs
handle :: SDL.EventPayload -> Affection UserData () handle :: SDL.EventPayload -> Affection UserData ()
handle (SDL.KeyboardEvent dat) = handle (SDL.KeyboardEvent dat) =
when (not (SDL.keyboardEventRepeat dat)) $ do when (not (SDL.keyboardEventRepeat dat)) $ do