working on drawing primitives

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

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

examples/example01.hs

@@ -67,44 +67,44 @@ load _ = do
     , ("foreground"  , bufsrc)
     ]
   let roi = G.GeglRectangle 0 0 20 20
-  G.iterateOver
+  -- G.iterateOver
-    buffer
+  --   buffer
-    roi
+  --   roi
-    (B.PixelFormat B.RGBA B.CFfloat)
+  --   (B.PixelFormat B.RGBA B.CFfloat)
-    G.GeglAccessReadWrite
+  --   G.GeglAccessReadWrite
-    G.GeglAbyssNone
+  --   G.GeglAbyssNone
-    (\(G.Pixel px py pc) ->
+  --   (\(G.Pixel px py pc) ->
-      let dsqr = (((10 - px) ^ 2) + ((10 - py) ^ 2))
+  --     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
+  --         (G.CVfloat (CFloat pr), G.CVfloat (CFloat pg), G.CVfloat (CFloat pb), G.CVfloat (CFloat pa)) = pc
-          dist = (sqrt (fromIntegral dsqr :: Float))
+  --         dist = (sqrt (fromIntegral dsqr :: Float))
-      in if dsqr < 100
+  --     in if dsqr < 100
-        then
+  --       then
-          if dist < fromIntegral 9
+  --         if dist < fromIntegral 9
-            then
+  --           then
-              G.Pixel px py
+  --             G.Pixel px py
-                ( G.CVfloat $ CFloat 0
+  --               ( G.CVfloat $ CFloat 0
-                , G.CVfloat $ CFloat 0
+  --               , G.CVfloat $ CFloat 0
-                , G.CVfloat $ CFloat 0
+  --               , G.CVfloat $ CFloat 0
-                , G.CVfloat $ CFloat $ if pa < 1 then 1 else pa
+  --               , G.CVfloat $ CFloat $ if pa < 1 then 1 else pa
-                )
+  --               )
-            else
+  --           else
-              let alpha = fromIntegral 10 - dist
+  --             let alpha = fromIntegral 10 - dist
-                  dst_a = pa
+  --                 dst_a = pa
-                  a = alpha + dst_a * (1 - alpha)
+  --                 a = alpha + dst_a * (1 - alpha)
-                  a_term = dst_a * (1 - alpha)
+  --                 a_term = dst_a * (1 - alpha)
-                  red = 0 * alpha + pr * a_term
+  --                 red = 0 * alpha + pr * a_term
-                  gre = 0 * alpha + pg * a_term
+  --                 gre = 0 * alpha + pg * a_term
-                  blu = 0 * alpha + pb * a_term
+  --                 blu = 0 * alpha + pb * a_term
-              in
+  --             in
-                G.Pixel px py
+  --               G.Pixel px py
-                  ( G.CVfloat $ CFloat $ red / a
+  --                 ( G.CVfloat $ CFloat $ red / a
-                  , G.CVfloat $ CFloat $ gre / a
+  --                 , G.CVfloat $ CFloat $ gre / a
-                  , G.CVfloat $ CFloat $ blu / a
+  --                 , G.CVfloat $ CFloat $ blu / a
-                  , G.CVfloat $ CFloat $ if pa < alpha then alpha else pa
+  --                 , G.CVfloat $ CFloat $ if pa < alpha then alpha else pa
-                  )
+  --                 )
-      else
+  --     else
-        G.Pixel px py pc
+  --       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

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

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
+    )

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
+    }