diff --git a/affection.cabal b/affection.cabal index 5aea7e6..4c15e11 100644 --- a/affection.cabal +++ b/affection.cabal @@ -33,7 +33,7 @@ flag examples library exposed-modules: Affection - -- , Affection.Render + , Affection.Draw , Affection.Types default-extensions: OverloadedStrings @@ -56,6 +56,7 @@ library , linear , mtl , gegl + , babl , monad-loops , clock -- , sdl2-image diff --git a/examples/example00.hs b/examples/example00.hs index e8df2d8..a240d6d 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -71,7 +71,7 @@ load _ = do , elapsedTime = 0 } -draw :: AffectionState (AffectionData UserData) IO () +draw :: Affection UserData () draw = do traceM "drawing" AffectionData{..} <- get @@ -95,7 +95,7 @@ draw = do liftIO $ SDL.unlockSurface drawSurface liftIO $ SDL.updateWindowSurface drawWindow -update :: Double -> AffectionState (AffectionData UserData) IO () +update :: Double -> Affection UserData () update sec = do traceM "updating" -- liftIO $ delaySec 5 diff --git a/examples/example01.hs b/examples/example01.hs index 35606e3..80fb49e 100644 --- a/examples/example01.hs +++ b/examples/example01.hs @@ -67,44 +67,44 @@ load _ = do , ("foreground" , bufsrc) ] let roi = G.GeglRectangle 0 0 20 20 - G.iterateOver - buffer - roi - (B.PixelFormat B.RGBA B.CFfloat) - G.GeglAccessReadWrite - G.GeglAbyssNone - (\(G.Pixel px py pc) -> - let dsqr = (((10 - px) ^ 2) + ((10 - py) ^ 2)) - (G.CVfloat (CFloat pr), G.CVfloat (CFloat pg), G.CVfloat (CFloat pb), G.CVfloat (CFloat pa)) = pc - dist = (sqrt (fromIntegral dsqr :: Float)) - in if dsqr < 100 - then - if dist < fromIntegral 9 - then - G.Pixel px py - ( G.CVfloat $ CFloat 0 - , G.CVfloat $ CFloat 0 - , G.CVfloat $ CFloat 0 - , G.CVfloat $ CFloat $ if pa < 1 then 1 else pa - ) - else - let alpha = fromIntegral 10 - dist - dst_a = pa - a = alpha + dst_a * (1 - alpha) - a_term = dst_a * (1 - alpha) - red = 0 * alpha + pr * a_term - gre = 0 * alpha + pg * a_term - blu = 0 * alpha + pb * a_term - in - G.Pixel px py - ( G.CVfloat $ CFloat $ red / a - , G.CVfloat $ CFloat $ gre / a - , G.CVfloat $ CFloat $ blu / a - , G.CVfloat $ CFloat $ if pa < alpha then alpha else pa - ) - else - G.Pixel px py pc - ) + -- G.iterateOver + -- buffer + -- roi + -- (B.PixelFormat B.RGBA B.CFfloat) + -- G.GeglAccessReadWrite + -- G.GeglAbyssNone + -- (\(G.Pixel px py pc) -> + -- let dsqr = (((10 - px) ^ 2) + ((10 - py) ^ 2)) + -- (G.CVfloat (CFloat pr), G.CVfloat (CFloat pg), G.CVfloat (CFloat pb), G.CVfloat (CFloat pa)) = pc + -- dist = (sqrt (fromIntegral dsqr :: Float)) + -- in if dsqr < 100 + -- then + -- if dist < fromIntegral 9 + -- then + -- G.Pixel px py + -- ( G.CVfloat $ CFloat 0 + -- , G.CVfloat $ CFloat 0 + -- , G.CVfloat $ CFloat 0 + -- , G.CVfloat $ CFloat $ if pa < 1 then 1 else pa + -- ) + -- else + -- let alpha = fromIntegral 10 - dist + -- dst_a = pa + -- a = alpha + dst_a * (1 - alpha) + -- a_term = dst_a * (1 - alpha) + -- red = 0 * alpha + pr * a_term + -- gre = 0 * alpha + pg * a_term + -- blu = 0 * alpha + pb * a_term + -- in + -- G.Pixel px py + -- ( G.CVfloat $ CFloat $ red / a + -- , G.CVfloat $ CFloat $ gre / a + -- , G.CVfloat $ CFloat $ blu / a + -- , G.CVfloat $ CFloat $ if pa < alpha then alpha else pa + -- ) + -- else + -- G.Pixel px py pc + -- ) traceM "loading complete" return $ UserData { nodeGraph = myMap @@ -112,7 +112,7 @@ load _ = do , elapsedTime = 0 } -draw :: AffectionState (AffectionData UserData) IO () +draw :: Affection UserData () draw = do traceM "drawing" AffectionData{..} <- get @@ -125,6 +125,7 @@ draw = do format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8) SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface let (w, h) = (fromIntegral rw, fromIntegral rh) + drawRect foreground (G.RGB 1 0 0) (Line 2) (G.GeglRectangle 5 5 200 200) liftIO $ G.gegl_node_blit (nodeGraph M.! "over" :: G.GeglNode) 1 diff --git a/src/Affection.hs b/src/Affection.hs index ad82c5e..addd755 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -6,10 +6,11 @@ module Affection , delaySec , get , put - , module Types + , module A ) where import qualified SDL +import qualified SDL.Internal.Numbered as SDL (toNumber) import qualified SDL.Raw as Raw import qualified GEGL as G @@ -22,7 +23,8 @@ import Control.Monad.Loops import Control.Monad.State import Control.Concurrent.MVar -import Affection.Types as Types +import Affection.Types as A +import Affection.Draw as A -- | Main function which bootstraps everything else. withAffection @@ -46,10 +48,10 @@ withAffection AffectionConfig{..} = do , drawWindow = window , drawSurface = surface }) =<< loadState surface - (_, nState) <- runStateT ( Types.runState $ + (_, nState) <- runStateT ( A.runState $ whileM_ (do current <- get - return $ not $ Types.quitEvent current + return $ not $ A.quitEvent current ) (do now <- liftIO $ getTime Monotonic diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs new file mode 100644 index 0000000..91d95b1 --- /dev/null +++ b/src/Affection/Draw.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Module for drawing primitives +module Affection.Draw + ( drawRect + ) where + +import Affection.Types (DrawType(..), Affection, GeglRectangle(..), liftIO) + +import Foreign.C.Types + +import qualified BABL as B + +import qualified GEGL as G + +-- | Draw a rectangle on target buffer +drawRect + :: G.GeglBuffer -- ^ Target buffer + -> G.Color -- ^ Color to draw in + -> DrawType -- ^ Draw type + -> GeglRectangle -- ^ Dimensions of Rectangle + -> Affection a () +drawRect buf color dt rect@G.GeglRectangle{..} = + liftIO $ G.iterateOver buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $ + (\(G.Pixel px py pc) -> + case dt of + Fill -> + let col = colorize pc color + in + G.Pixel px py col + Line width -> + if (px >= rectangleX && px <= (rectangleX + width) || + px <= (rectangleX + rectangleWidth) && px >= (rectangleX + rectangleWidth - width)) && + (py >= rectangleY && py <= (rectangleY + width) || + py <= (rectangleY + rectangleHeight) && py >= (rectangleY + rectangleHeight - width)) + then + let col = colorize pc color + in G.Pixel px py col + else + G.Pixel px py pc + ) + +-- | compute color for a single pixel +colorize + :: (G.ComponentValue, G.ComponentValue, G.ComponentValue, G.ComponentValue) -- ^ Pixel information in buffer + -> G.Color -- ^ Color to draw over + -> (G.ComponentValue, G.ComponentValue, G.ComponentValue, G.ComponentValue) -- ^ Resulting colour +colorize (rr, rg, rb, ra) col = + let (G.CVdouble (CDouble br)) = rr + (G.CVdouble (CDouble bg)) = rg + (G.CVdouble (CDouble bb)) = rb + (G.CVdouble (CDouble ba)) = ra + (cr, cg, cb) = case col of + G.RGBA r g b _ -> (r, g, b) + G.RGB r g b -> (r, g, b) + ca = case col of + G.RGBA _ _ _ a -> a + G.RGB _ _ _ -> 1 + alpha = ca + dst_a = ba + da = alpha + dst_a * (1 - alpha) + a_term = dst_a * (1 - alpha) + red = cr * alpha + br * a_term + gre = cg * alpha + bg * a_term + blu = cb * alpha + bb * a_term + in + ( G.CVdouble $ CDouble $ red / da + , G.CVdouble $ CDouble $ gre / da + , G.CVdouble $ CDouble $ blu / da + , G.CVdouble $ CDouble $ ca + ) diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 33618d8..a710371 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} module Affection.Types - ( AffectionData(..) + ( Affection + , AffectionData(..) , AffectionConfig(..) , AffectionState(..) -- , AffectionDraw(..) @@ -10,15 +11,20 @@ module Affection.Types , InitComponents(..) -- , Loop(..) , RGBA(..) + , DrawType(..) , SDL.WindowConfig(..) , SDL.defaultWindow -- | Convenience exports , liftIO + -- | GEGL reexports + , G.GeglRectangle(..) + , G.GeglBuffer(..) ) where import qualified SDL.Init as SDL import qualified SDL.Video as SDL import qualified Data.Text as T +import qualified GEGL as G import Control.Monad.IO.Class import Control.Monad.State @@ -71,6 +77,8 @@ newtype AffectionState us m a = AffectionState { runState :: AffectionStateInner us m a } deriving (Functor, Applicative, Monad, MonadIO, MonadState us) +type Affection us a = AffectionState (AffectionData us) IO a + -- -- | Inner 'StateT' monad of Affection -- type AffectionInner us od a = StateT (AffectionState us od) IO a -- @@ -98,3 +106,10 @@ data RGBA = RGBA , b :: Int , a :: Int } + +-- | Type for defining the draw type of draw functions +data DrawType + = Fill -- ^ Fill the specified area completely with color + | Line -- ^ only draw the outline of the area + { lineWidth :: Int -- ^ Width of line in pixels + }