313 lines
8.9 KiB
Haskell
313 lines
8.9 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.HashMap.Strict as HM
|
|
import qualified Data.HashSet as HS
|
|
import qualified Data.Matrix as X
|
|
import Data.List as L
|
|
import Data.Foldable (foldrM, foldlM)
|
|
import Data.Maybe (fromJust, catMaybes)
|
|
-- import Data.Vector as V
|
|
import System.Random (randomRIO)
|
|
import Control.Monad as CM (when, unless)
|
|
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 = 60
|
|
|
|
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
|
|
, initScreenMode = SDL.Windowed
|
|
, preLoop = loadList
|
|
, 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]
|
|
, liveIndices :: HS.HashSet (Int, Int)
|
|
, indices :: [(Int, Int)]
|
|
, cells :: HM.HashMap (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 <- foldrM (\index@(row, col) acc -> 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"
|
|
let tempMap = M.fromList
|
|
[ ("over", tempOver)
|
|
, ("rect", tempRect)
|
|
]
|
|
tempAProps =
|
|
map (\p -> ActorProperty
|
|
{ apName = G.propertyName p
|
|
, apValue = G.propertyValue p
|
|
, apMapping = Just ("rect", "color")
|
|
}) tempProps
|
|
traceIO $ show index
|
|
return $ HM.insert index Actor
|
|
{ actorProperties = tempAProps
|
|
, actorNodes = tempMap
|
|
}
|
|
acc
|
|
)
|
|
HM.empty
|
|
indices
|
|
traceM "loading complete"
|
|
return UserData
|
|
{ nodeGraph = myMap
|
|
, foreground = buffer
|
|
, keysDown = []
|
|
, indices = indices
|
|
, liveIndices = HS.empty
|
|
, cells = cells
|
|
, updateActors = []
|
|
}
|
|
|
|
loadList :: Affection UserData ()
|
|
loadList = do
|
|
ud@UserData{..} <- getAffection
|
|
-- init <- foldrM (\coord acc -> do
|
|
init <- foldlM (\acc coord -> do
|
|
trig <- liftIO $ randomRIO (True, False)
|
|
if trig then return (HS.insert coord acc) else return acc
|
|
) HS.empty indices
|
|
putAffection ud
|
|
{ liveIndices = init
|
|
}
|
|
|
|
getNeighbors :: (Int, Int) -> [(Int, Int)]
|
|
getNeighbors (row, col) =
|
|
map (\(pr, pc) -> (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
|
|
let livingActors = parMap rpar (cells HM.!) $ HS.toList liveIndices
|
|
unless (null livingActors) $ do
|
|
liftIO $ G.gegl_node_link_many $
|
|
parMap rpar (\a -> (actorNodes a) M.! "over") livingActors
|
|
_ <- 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
|
|
-- _ <- liftIO $ MP.mapM
|
|
-- (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input"
|
|
-- ) livingActors
|
|
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
|
|
|
|
relevant <- getRelevant (liveIndices ud)
|
|
|
|
-- 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
|
|
| coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) =
|
|
HS.insert coord acc
|
|
| neighs == 3 =
|
|
HS.insert coord acc
|
|
| otherwise =
|
|
acc
|
|
return ret
|
|
) 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
|
|
|
|
ud2 <- getAffection
|
|
putAffection ud2
|
|
{ liveIndices = new
|
|
}
|
|
|
|
mapM_ (\code ->
|
|
when (code == SDL.KeycodeR) loadList
|
|
) (keysDown ud)
|
|
|
|
getRelevant :: HS.HashSet (Int, Int) -> Affection UserData (HS.HashSet (Int, Int))
|
|
getRelevant ls = do
|
|
getRelevant' ls
|
|
where
|
|
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
|
|
|
|
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 ()
|
|
|
|
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
|