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
|
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
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue