From 1875797cb109a3bc8c12039a21852e96262eefb8 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 29 Mar 2017 16:37:36 +0200 Subject: [PATCH] optimization --- examples/example05.hs | 335 +++++++++--------------------------------- 1 file changed, 73 insertions(+), 262 deletions(-) diff --git a/examples/example05.hs b/examples/example05.hs index e1e53c6..612770e 100644 --- a/examples/example05.hs +++ b/examples/example05.hs @@ -19,7 +19,7 @@ import Foreign.Marshal.Utils import Debug.Trace dimension :: Int -dimension = 30 +dimension = 60 resolution :: Int resolution = 600 @@ -35,7 +35,7 @@ main = do (CInt $ fromIntegral resolution) } , canvasSize = Nothing - , preLoop = loadMatrix + , preLoop = loadList , eventLoop = handle , updateLoop = Main.update , drawLoop = draw @@ -48,9 +48,8 @@ data UserData = UserData { nodeGraph :: M.Map String G.GeglNode , foreground :: G.GeglBuffer , keysDown :: [SDL.Keycode] - , matrix :: X.Matrix Bool + , liveIndices :: [(Int, Int)] , indices :: [(Int, Int)] - -- , cells :: [((Int, Int), M.Map String G.GeglNode)] , cells :: [((Int, Int), Actor String)] , updateActors :: [Actor String] } @@ -109,8 +108,6 @@ load = do tempRect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" tempProps 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 [ ("over", tempOver) , ("rect", tempRect) @@ -130,234 +127,73 @@ load = do ([] :: [((Int, Int), Actor String)]) indices :: IO [((Int, Int), Actor String)] - -- _ <- G.gegl_node_link ((actorNodes $ snd $ last cells) M.! "over") nop traceM "loading complete" return UserData { nodeGraph = myMap , foreground = buffer , keysDown = [] - , matrix = emptyMatrix , indices = indices + , liveIndices = [] , cells = cells , updateActors = [] } -loadMatrix :: Affection UserData () -loadMatrix = do - !init <- liftIO $ X.fromList dimension dimension <$> MP.mapM (const (randomRIO (False, True))) [1..(dimension ^ 2)] - ud <- getAffection +loadList :: Affection UserData () +loadList = do + ud@UserData{..} <- getAffection + init <- foldM (\acc coord -> do + trig <- liftIO $ randomRIO (True, False) + if trig then return (coord : acc) else return acc + ) [] indices putAffection ud - { matrix = init + { liveIndices = init } - traceM "matrix initialized" -getNeighbors :: (Int, Int) -> Affection UserData (X.Matrix Bool) -getNeighbors (row, col) - | row == 1 && col == 1 = do +getNeighbors :: (Int, Int) -> Affection UserData [(Int, Int)] +getNeighbors (row, col) = + do UserData{..} <- getAffection - return $ X.joinBlocks - ( X.submatrix - dimension - dimension - dimension - dimension - matrix - , X.submatrix - dimension - dimension - col - (col + 1) - matrix - , X.submatrix - row - (row + 1) - dimension - dimension - matrix - , X.submatrix - 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 + mapM (\(pr, pc) -> + return (overflow(row + pr), overflow(col + pc)) + ) lcs + where + overflow x + | x < 1 = dimension + | x > dimension = 1 + | otherwise = x + +lcs :: [(Int, Int)] +lcs = + [ (-1, -1) + , (-1, 0) + , (-1, 1) + , (0, -1) + -- , (0, 0) + , (0, 1) + , (1, -1) + , (1, 0) + , (1, 1) + ] draw :: Affection UserData () draw = do traceM "drawing" ud@UserData{..} <- getAffection - _ <- liftIO $ MP.mapM - (\(_, 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 + let livingActors = catMaybes $ parMap rpar (\i -> lookup i cells) liveIndices unless (null livingActors) $ do 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") (nodeGraph M.! "nop") return () - -- MP.mapM_ applyProperties updateActors process (nodeGraph M.! "sink") present (G.GeglRectangle 0 0 resolution resolution) foreground True render Nothing Nothing + _ <- liftIO $ MP.mapM + (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input" + ) livingActors putAffection ud { updateActors = [] } @@ -371,70 +207,45 @@ update dt = do traceM $ show (1 / dt) ++ " FPS" traceM $ show $ keysDown ud - new <- MP.mapM (\coord@(row, col) -> do - neighs <- X.toList <$> getNeighbors coord - if True `elem` neighs - then do - let !living = sum $ parMap rpar (fromBool) neighs - if matrix ud X.! coord - then - if living - 1 == 2 || living - 1 == 3 - then - return True - else do - -- tud <- getAffection - -- let nac = updateProperties (props $ do - -- prop "color" $ G.RGB 0 0 0 - -- ) (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 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) + + relevant <- getRelevant (liveIndices ud) + + new <- catMaybes <$> MP.mapM (\coord@(row, col) -> do + neighs <- + foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 <$> + getNeighbors coord + let ret + | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) = + Just coord + | neighs == 3 = + Just coord + | otherwise = + Nothing + return ret + ) relevant + ud2 <- getAffection 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 -> - when (code == SDL.KeycodeR) loadMatrix + when (code == SDL.KeycodeR) loadList ) (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.KeyboardEvent dat) = when (not (SDL.keyboardEventRepeat dat)) $ do