pituicat/examples/example05.hs

313 lines
8.9 KiB
Haskell
Raw Normal View History

2017-03-28 22:43:09 +00:00
{-# 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
2017-04-17 10:40:17 +00:00
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
2017-03-28 22:43:09 +00:00
import qualified Data.Matrix as X
import Data.List as L
2017-04-17 10:40:17 +00:00
import Data.Foldable (foldrM, foldlM)
2017-03-28 22:43:09 +00:00
import Data.Maybe (fromJust, catMaybes)
-- import Data.Vector as V
import System.Random (randomRIO)
2017-04-17 10:40:17 +00:00
import Control.Monad as CM (when, unless)
2017-03-28 22:43:09 +00:00
import qualified Control.Monad.Parallel as MP
import Control.Parallel.Strategies
import Foreign.C.Types
import Foreign.Marshal.Utils
import Debug.Trace
dimension :: Int
2017-03-29 14:37:36 +00:00
dimension = 60
2017-03-28 22:43:09 +00:00
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
2017-03-29 14:37:36 +00:00
, preLoop = loadList
2017-03-28 22:43:09 +00:00
, 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]
2017-04-17 10:40:17 +00:00
, liveIndices :: HS.HashSet (Int, Int)
2017-03-28 22:43:09 +00:00
, indices :: [(Int, Int)]
2017-04-17 10:40:17 +00:00
, cells :: HM.HashMap (Int, Int) (Actor String)
2017-03-28 22:43:09 +00:00
, 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"
2017-04-17 10:40:17 +00:00
cells <- foldrM (\index@(row, col) acc -> do
2017-03-28 22:43:09 +00:00
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"
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
2017-04-17 10:40:17 +00:00
return $ HM.insert index Actor
2017-03-28 22:43:09 +00:00
{ actorProperties = tempAProps
, actorNodes = tempMap
2017-04-17 10:40:17 +00:00
}
acc
2017-03-28 22:43:09 +00:00
)
2017-04-17 10:40:17 +00:00
HM.empty
2017-03-28 22:43:09 +00:00
indices
traceM "loading complete"
return UserData
{ nodeGraph = myMap
, foreground = buffer
, keysDown = []
, indices = indices
2017-04-17 10:40:17 +00:00
, liveIndices = HS.empty
2017-03-28 22:43:09 +00:00
, cells = cells
, updateActors = []
}
2017-03-29 14:37:36 +00:00
loadList :: Affection UserData ()
loadList = do
ud@UserData{..} <- getAffection
2017-04-17 10:40:17 +00:00
-- init <- foldrM (\coord acc -> do
init <- foldlM (\acc coord -> do
2017-03-29 14:37:36 +00:00
trig <- liftIO $ randomRIO (True, False)
2017-04-17 10:40:17 +00:00
if trig then return (HS.insert coord acc) else return acc
) HS.empty indices
2017-03-28 22:43:09 +00:00
putAffection ud
2017-03-29 14:37:36 +00:00
{ liveIndices = init
2017-03-28 22:43:09 +00:00
}
2017-04-17 10:40:17 +00:00
getNeighbors :: (Int, Int) -> [(Int, Int)]
2017-03-29 14:37:36 +00:00
getNeighbors (row, col) =
2017-04-17 10:40:17 +00:00
map (\(pr, pc) -> (overflow(row + pr), overflow(col + pc))) lcs
2017-03-29 14:37:36 +00:00
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)
]
2017-03-28 22:43:09 +00:00
draw :: Affection UserData ()
draw = do
traceM "drawing"
ud@UserData{..} <- getAffection
2017-04-17 10:40:17 +00:00
let livingActors = parMap rpar (cells HM.!) $ HS.toList liveIndices
2017-03-28 22:43:09 +00:00
unless (null livingActors) $ do
liftIO $ G.gegl_node_link_many $
2017-03-29 14:37:36 +00:00
parMap rpar (\a -> (actorNodes a) M.! "over") livingActors
2017-03-28 22:43:09 +00:00
_ <- liftIO $ G.gegl_node_link ((actorNodes $ last livingActors) M.! "over")
(nodeGraph M.! "nop")
return ()
process (nodeGraph M.! "sink")
present (G.GeglRectangle 0 0 resolution resolution) foreground True
render
Nothing
Nothing
2017-04-17 10:40:17 +00:00
-- _ <- liftIO $ MP.mapM
-- (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input"
-- ) livingActors
2017-03-28 22:43:09 +00:00
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
2017-03-29 14:37:36 +00:00
relevant <- getRelevant (liveIndices ud)
2017-04-17 10:40:17 +00:00
-- let new = HS.fromList $ catMaybes $ parMap rpar (\coord@(row, col) ->
-- let neighs =
-- foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 $
-- getNeighbors coord
-- ret
-- | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
-- Just coord
-- | neighs == 3 =
-- Just coord
-- | otherwise =
-- Nothing
-- in ret
-- ) (HS.toList relevant)
new <- foldrM (\coord@(row, col) acc -> do
-- new <- foldlM (\acc coord@(row, col) -> do
let !neighs = sum $
map (\n -> if n `elem` liveIndices ud then 1 else 0)$
getNeighbors coord
ret
2017-03-29 14:37:36 +00:00
| coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
2017-04-17 10:40:17 +00:00
HS.insert coord acc
2017-03-29 14:37:36 +00:00
| neighs == 3 =
2017-04-17 10:40:17 +00:00
HS.insert coord acc
2017-03-29 14:37:36 +00:00
| otherwise =
2017-04-17 10:40:17 +00:00
acc
2017-03-29 14:37:36 +00:00
return ret
2017-04-17 10:40:17 +00:00
) HS.empty relevant
-- 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
2017-03-29 14:37:36 +00:00
2017-03-28 22:43:09 +00:00
ud2 <- getAffection
putAffection ud2
2017-03-29 14:37:36 +00:00
{ liveIndices = new
2017-03-28 22:43:09 +00:00
}
mapM_ (\code ->
2017-03-29 14:37:36 +00:00
when (code == SDL.KeycodeR) loadList
2017-03-28 22:43:09 +00:00
) (keysDown ud)
2017-04-17 10:40:17 +00:00
getRelevant :: HS.HashSet (Int, Int) -> Affection UserData (HS.HashSet (Int, Int))
getRelevant ls = do
2017-03-29 14:37:36 +00:00
getRelevant' ls
where
2017-04-17 10:40:17 +00:00
getRelevant' xs = foldlM (\acc x ->
let neighs = getNeighbors x
slice = (x : neighs)
rels = foldr (\y a ->
-- rels = foldl (\a y ->
if y `elem` acc then a else HS.insert y a
) HS.empty slice
in return (acc `HS.union` rels)
) HS.empty xs
2017-03-29 14:37:36 +00:00
2017-03-28 22:43:09 +00:00
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 ()
2017-04-17 10:40:17 +00:00
parHSMap f = (`using` parTraversable rpar) . HM.map f
-- catHSMaybe =
-- foldr (\x acc ->
-- case x of
-- Just a -> a `HS.insert` acc
-- Nothing -> acc
-- ) HS.empty