optimization
This commit is contained in:
nek0
parent
121c9fb120
commit
1875797cb1
1 changed files with 73 additions and 262 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue