diff --git a/affection.cabal b/affection.cabal --- a/affection.cabal +++ b/affection.cabal @@ -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. diff --git a/examples/example03.hs b/examples/example03.hs --- a/examples/example03.hs +++ b/examples/example03.hs @@ -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 diff --git a/src/Affection.hs b/src/Affection.hs --- a/src/Affection.hs +++ b/src/Affection.hs @@ -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 diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs --- a/src/Affection/Draw.hs +++ b/src/Affection/Draw.hs @@ -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 diff --git a/src/Affection/MouseInteractable.hs b/src/Affection/MouseInteractable.hs new file mode 100644 --- /dev/null +++ b/src/Affection/MouseInteractable.hs @@ -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 () diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs --- a/src/Affection/Particle.hs +++ b/src/Affection/Particle.hs @@ -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 diff --git a/src/Affection/StateMachine.hs b/src/Affection/StateMachine.hs new file mode 100644 --- /dev/null +++ b/src/Affection/StateMachine.hs @@ -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 () diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -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