affection/examples/example05.hs
2017-03-29 00:43:09 +02:00

462 lines
12 KiB
Haskell

{-# LANGUAGE RecordWildCards, BangPatterns #-}
import Affection
import qualified SDL
import qualified GEGL as G
import qualified BABL as B
import qualified Data.Map.Strict as M
import qualified Data.Matrix as X
import Data.List as L
import Data.Maybe (fromJust, catMaybes)
-- import Data.Vector as V
import System.Random (randomRIO)
import Control.Monad as CM (when, unless, foldM)
import qualified Control.Monad.Parallel as MP
import Control.Parallel.Strategies
import Foreign.C.Types
import Foreign.Marshal.Utils
import Debug.Trace
dimension :: Int
dimension = 30
resolution :: Int
resolution = 600
main :: IO ()
main = do
conf <- return AffectionConfig
{ initComponents = All
, windowTitle = "Affection: example00"
, windowConfig = SDL.defaultWindow
{ windowInitialSize = SDL.V2
(CInt $ fromIntegral resolution)
(CInt $ fromIntegral resolution)
}
, canvasSize = Nothing
, preLoop = loadMatrix
, eventLoop = handle
, updateLoop = Main.update
, drawLoop = draw
, loadState = load
, cleanUp = clean
}
withAffection conf
data UserData = UserData
{ nodeGraph :: M.Map String G.GeglNode
, foreground :: G.GeglBuffer
, keysDown :: [SDL.Keycode]
, matrix :: X.Matrix Bool
, indices :: [(Int, Int)]
-- , cells :: [((Int, Int), M.Map String G.GeglNode)]
, cells :: [((Int, Int), Actor String)]
, updateActors :: [Actor String]
}
load :: IO UserData
load = do
traceM "loading"
root <- G.gegl_node_new
traceM "new root node"
let bgProps = props $ do
prop "x" (0 :: Double)
prop "y" (0 :: Double)
prop "width" (fromIntegral resolution :: Double)
prop "height" (fromIntegral resolution :: Double)
prop "color" $ G.RGB 0 0 0
bg <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" bgProps
traceM "background"
over <- G.gegl_node_new_child root G.defaultOverOperation
traceM "over"
buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 resolution resolution) =<<
B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $
props $
prop "buffer" buffer
traceM "buffer-sink"
crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $
props $ do
prop "width" (fromIntegral resolution :: Double)
prop "height" (fromIntegral resolution :: Double)
G.gegl_node_link_many [bg, over, crop, sink]
nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
_ <- G.gegl_node_connect_to nop "output" over "aux"
traceM "connections made"
myMap <- return $ M.fromList
[ ("root" , root)
, ("over" , over)
, ("background" , bg)
, ("sink" , sink)
, ("nop" , nop)
, ("crop" , crop)
]
traceM "building matrix"
let !emptyMatrix = X.matrix dimension dimension (const False)
!indices = [(row, col) | row <- [1..dimension], col <- [1..dimension]]
traceM "building cells"
cells <- foldM (\acc index@(row, col) -> do
tempOver <- G.gegl_node_new_child root $ G.defaultOverOperation
let !scale = (fromIntegral resolution) / (fromIntegral dimension)
tempProps =
props $ do
prop "x" (((fromIntegral col) - 1) * scale :: Double)
prop "y" (((fromIntegral row) - 1) * scale :: Double)
prop "width" (scale :: Double)
prop "height" (scale :: Double)
prop "color" $ G.RGB 1 1 1
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)
]
tempAProps =
map (\p -> ActorProperty
{ apName = G.propertyName p
, apValue = G.propertyValue p
, apMapping = Just "rect"
}) tempProps
traceIO $ show index
return $ (index, Actor
{ actorProperties = tempAProps
, actorNodes = tempMap
}) : acc
)
([] :: [((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
, 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
putAffection ud
{ matrix = init
}
traceM "matrix initialized"
getNeighbors :: (Int, Int) -> Affection UserData (X.Matrix Bool)
getNeighbors (row, col)
| row == 1 && col == 1 = 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
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
unless (null livingActors) $ do
liftIO $ G.gegl_node_link_many $
map (\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
putAffection ud
{ updateActors = []
}
update :: Double -> Affection UserData ()
update dt = do
traceM "updating"
ud <- getAffection
elapsed <- getElapsedTime
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)
ud2 <- getAffection
putAffection ud2
{ matrix = X.fromList dimension dimension 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
) (keysDown ud)
handle :: SDL.EventPayload -> Affection UserData ()
handle (SDL.KeyboardEvent dat) =
when (not (SDL.keyboardEventRepeat dat)) $ do
ud <- getAffection
if (SDL.keyboardEventKeyMotion dat == SDL.Pressed)
then
putAffection ud
{ keysDown =
SDL.keysymKeycode (SDL.keyboardEventKeysym dat) : keysDown ud
}
else
putAffection ud
{ keysDown =
delete (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) (keysDown ud)
}
handle (SDL.WindowClosedEvent _) = do
traceM "seeya!"
quit
handle _ =
return ()
clean :: UserData -> IO ()
clean _ = return ()