affection 0.0.0.4 → 0.0.0.5
raw patch · 8 files changed
+137/−111 lines, 8 files
Files
- affection.cabal +3/−1
- examples/example03.hs +8/−8
- src/Affection.hs +16/−11
- src/Affection/Draw.hs +39/−27
- src/Affection/MouseInteractable.hs +20/−0
- src/Affection/Particle.hs +35/−62
- src/Affection/StateMachine.hs +14/−0
- src/Affection/Types.hs +2/−2
affection.cabal view
@@ -6,7 +6,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.0.0.4+version: 0.0.0.5 synopsis: A simple Game Engine using SDL description: This package contains Affection, a simple game engine written in Haskell using SDL and GEGL.@@ -39,6 +39,8 @@ , Affection.Draw , Affection.Particle , Affection.Types+ , Affection.StateMachine+ , Affection.MouseInteractable default-extensions: OverloadedStrings -- Modules included in this library but not exported.
examples/example03.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-} import Affection import qualified SDL@@ -173,23 +174,22 @@ return () ) evs ud2 <- getAffection- nps <- updateParticleSystem (partsys ud2) sec partUpd partDraw+ !nps <- updateParticleSystem (partsys ud2) sec partUpd partDraw putAffection $ ud2 { partsys = nps } clean :: UserData -> IO () clean _ = return () partUpd :: Double -> Particle -> Affection UserData Particle-partUpd sec p@Particle{..} = do- let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)- newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity)- liftIO $ G.gegl_node_set (particleNodeGraph M.! "rect") $ G.Operation "gegl:rectangle"+partUpd sec p = do+ let !newX = (fst $ particlePosition p) + sec * (fromIntegral $ fst $ particleVelocity p)+ !newY = (snd $ particlePosition p) + sec * (fromIntegral $ snd $ particleVelocity p)+ liftIO $ G.gegl_node_set (particleNodeGraph p M.! "rect") $ G.Operation "gegl:rectangle" [ G.Property "x" $ G.PropertyDouble $ newX - 10 , G.Property "y" $ G.PropertyDouble $ newY - 10 ]- return p- { particlePosition = (newX, newY)- }+ let !np = p {particlePosition = (newX, newY)}+ return np partDraw :: G.GeglBuffer -> G.GeglNode -> Particle -> Affection UserData () partDraw buf node Particle{..} = do
src/Affection.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-} module Affection ( withAffection , getAffection@@ -32,6 +33,8 @@ import Affection.Types as A import Affection.Draw as A import Affection.Particle as A+import Affection.StateMachine as A+import Affection.MouseInteractable as A import qualified BABL as B @@ -108,10 +111,11 @@ -- clean the renderer form last time SDL.clear renderer -- compute dt and update elapsedTime- let dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9)+ let !dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9)+ !ne = elapsedTime ad + dt put $ ad { drawStack = []- , elapsedTime = elapsedTime ad + dt+ , elapsedTime = ne } -- poll events evs <- preHandleEvents =<< liftIO SDL.pollEvents@@ -152,15 +156,16 @@ -- Prehandle SDL events in case any window events occur preHandleEvents :: [SDL.Event] -> Affection us [SDL.Event] preHandleEvents evs =- mapM handle evs- where- handle e =- case SDL.eventPayload e of- SDL.WindowMovedEvent _ -> do- liftIO $ traceIO "I was moved"- return e- _ ->- return e+ -- mapM handle evs+ -- where+ -- handle e =+ -- case SDL.eventPayload e of+ -- SDL.WindowMovedEvent _ -> do+ -- liftIO $ traceIO "I was moved"+ -- return e+ -- _ ->+ -- return e+ return evs -- | Return the userstate to the user getAffection :: Affection us us
src/Affection/Draw.hs view
@@ -12,6 +12,8 @@ import Affection.Types +import Data.Maybe (maybe)+ import Foreign import Foreign.C.Types @@ -59,7 +61,7 @@ -> Affection us () present rect buf kill = do ad <- get- let k = if not kill then Kill Nothing else Yes+ let k = if not kill then Kill Nothing else Persist put ad { drawStack = (DrawRequest rect buf k) : drawStack ad }@@ -75,20 +77,25 @@ handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do ad <- get let surf = drawSurface ad- liftIO $ SDL.lockSurface surf- liftIO $ G.gegl_buffer_get- requestBuffer- (Just requestArea)- 1- (Just $ drawFormat ad)- (pixels `plusPtr`- (rectangleX requestArea * cpp + rectangleY requestArea * stride))- stride- G.GeglAbyssNone- liftIO $ SDL.unlockSurface surf- -- liftIO $ SDL.updateWindowSurface $ drawWindow ad+ mrealRect <- liftIO $ G.gegl_rectangle_intersect+ requestArea+ (G.GeglRectangle 0 0 (fst $ drawDimensions ad) (snd $ drawDimensions ad))+ maybe (return()) (\realRect -> do+ liftIO $ SDL.lockSurface surf+ liftIO $ G.gegl_buffer_get+ requestBuffer+ (Just realRect)+ 1+ (Just $ drawFormat ad)+ (pixels `plusPtr`+ (rectangleX realRect * cpp + rectangleY realRect * stride))+ stride+ G.GeglAbyssNone+ liftIO $ SDL.unlockSurface surf+ -- liftIO $ SDL.updateWindowSurface $ drawWindow ad+ ) mrealRect case requestPersist of- Yes ->+ Persist -> return Nothing Kill _ -> return $ Just dr@@ -103,19 +110,24 @@ -> Affection us () invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do ad <- get- let surf = drawSurface ad- liftIO $ clearArea requestBuffer requestArea- liftIO $ SDL.lockSurface surf- liftIO $ G.gegl_buffer_get- requestBuffer- (Just requestArea)- 1- (Just $ drawFormat ad)- (pixels `plusPtr`- (rectangleX requestArea * cpp + rectangleY requestArea * stride))- stride- G.GeglAbyssNone- liftIO $ SDL.unlockSurface surf+ mrealRect <- liftIO $ G.gegl_rectangle_intersect+ requestArea+ (G.GeglRectangle 0 0 (fst $ drawDimensions ad) (snd $ drawDimensions ad))+ maybe (return()) (\realRect -> do+ let surf = drawSurface ad+ liftIO $ clearArea requestBuffer realRect+ liftIO $ SDL.lockSurface surf+ liftIO $ G.gegl_buffer_get+ requestBuffer+ (Just realRect)+ 1+ (Just $ drawFormat ad)+ (pixels `plusPtr`+ (rectangleX realRect * cpp + rectangleY realRect * stride))+ stride+ G.GeglAbyssNone+ liftIO $ SDL.unlockSurface surf+ ) mrealRect case requestPersist of Kill (Just victim) -> liftIO $ G.gegl_node_drop victim
+ src/Affection/MouseInteractable.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Affection.MouseInteractable where++import Affection.Types++import qualified SDL++-- class MouseHoverable a us where+-- onHover :: a -> Affection us ()++-- | Define a mouse clickable object+class MouseClickable a us where+ onClick+ :: a -- The object+ -> SDL.MouseButton -- The clicked button+ -> (Int, Int) -- The coordinates of the click+ -> SDL.InputMotion -- The 'SDL.InputMotion' of the click+ -> Int -- The number of clicks+ -> Affection us ()
src/Affection/Particle.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-} -- | This module introduces a simple particle system to Affection module Affection.Particle@@ -35,61 +36,31 @@ -- -> Affection us [Maybe Particle] -> Affection us (Maybe Particle) -- ^ resulting 'Particle'-updateParticle time funct pa = do- now <- elapsedTime <$> get- if particleCreation pa + particleTimeToLive pa < now- then do- mproducer <- liftIO $ G.gegl_node_get_producer- (particleStackCont pa)- "input"- case mproducer of- Just (producer, padname) -> do- consumers <- liftIO $ G.gegl_node_get_consumers- (particleStackCont pa)- "output"- liftIO $ mapM_ (\(node, inpad)-> G.gegl_node_connect_to- producer- padname- node- inpad- ) consumers- Nothing -> return ()- liftIO $ G.gegl_node_drop $ particleRootNode pa- return $ Nothing- else do- np <- Just <$> funct time pa- return $ np--- updateParticle time funct acc@[p] pa = do--- now <- elapsedTime <$> get--- if particleCreation pa + particleTimeToLive pa > now--- then do--- liftIO $ G.gegl_node_drop $ particleRootNode pa--- return $ Nothing : acc--- else do--- when (not $ isNothing p) $ do--- -- liftIO $ traceIO "linking second node in list"--- liftIO $ G.gegl_node_link--- (particleStackCont pa)--- (particleStackCont $ fromJust p)--- np <- Just <$> funct time pa--- return $ np : acc--- updateParticle time funct acc@(p:ps) pa = do--- now <- elapsedTime <$> get--- if particleCreation pa + particleTimeToLive pa > now--- then do--- liftIO $ G.gegl_node_drop $ particleRootNode pa--- return $ Nothing : acc--- else do--- when (isNothing p) $ do--- let mnl = nextLiving ps--- maybe--- (return ())--- (\nl -> do--- -- liftIO $ traceIO "linking nth node on list"--- liftIO $ G.gegl_node_link (particleStackCont pa) (particleStackCont nl))--- mnl--- np <- Just <$> funct time pa--- return $ np : acc+updateParticle time funct pa =+ do+ now <- elapsedTime <$> get+ if particleCreation pa + particleTimeToLive pa < now+ then do+ mproducer <- liftIO $ G.gegl_node_get_producer+ (particleStackCont pa)+ "input"+ case mproducer of+ Just (producer, padname) -> do+ consumers <- liftIO $ G.gegl_node_get_consumers+ (particleStackCont pa)+ "output"+ liftIO $ mapM_ (\(node, inpad)-> G.gegl_node_connect_to+ producer+ padname+ node+ inpad+ ) consumers+ Nothing -> return ()+ liftIO $ G.gegl_node_drop $ particleRootNode pa+ return $ Nothing+ else do+ np <- Just <$> funct time pa+ return $ np -- | Get the next living particle from a list nextLiving@@ -116,7 +87,7 @@ -> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ()) -> Affection us ParticleSystem updateParticleSystem sys sec upd draw = do- x <- catMaybes <$> mapM (updateParticle sec upd) (partStorList $ partSysParts sys)+ !x <- catMaybes <$> mapM (updateParticle sec upd) (partStorList $ partSysParts sys) -- liftIO $ traceIO $ show $ length x -- x <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys) if (not $ null x)@@ -125,17 +96,19 @@ -- liftIO $ traceIO "linking last node to output" liftIO $ G.gegl_node_link (particleStackCont $ head x) (partSysNode sys) mapM_ (draw (partSysBuffer sys) (partSysNode sys)) x- return $ sys+ return sys { partSysParts = (partSysParts sys) { partStorList = x- , partStorLatest =- if null x- then Nothing- else partStorLatest (partSysParts sys) } }- else+ else do+ _ <- liftIO $ G.gegl_node_disconnect (partSysNode sys) "input" return sys+ { partSysParts = ParticleStorage+ { partStorList = []+ , partStorLatest = Nothing+ }+ } -- | Function for inserting a new 'Particle' into its 'PartileSystem' insertParticle
+ src/Affection/StateMachine.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Affection.StateMachine where++import Affection.Types++import qualified SDL++class StateMachine a us where+ smLoad :: a -> Affection us ()+ smUpdate :: a -> Double -> Affection us ()+ smEvent :: a -> Double -> SDL.Event -> Affection us ()+ smDraw :: a -> Affection us ()+ smClean :: a -> Affection us ()
src/Affection/Types.hs view
@@ -82,7 +82,7 @@ , drawFormat :: B.BablFormatPtr -- ^ Target format , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed , drawPixels :: Ptr () -- ^ Destination Pixel buffer- , drawDimensions :: (Int, Int) -- ^ Dimensions of target surface+ , drawDimensions :: (Int, Int) -- ^ Dimensions of target surface , drawStride :: Int -- ^ Stride of target buffer , drawCPP :: Int -- ^ Number of components per pixel , elapsedTime :: Double -- ^ Elapsed time in seconds@@ -96,7 +96,7 @@ } data RequestPersist- = Yes+ = Persist | Kill (Maybe G.GeglNode) -- | A type for storing 'DrawRequest' results to be executed frequently. TODO