working on drawing primitives

This commit is contained in:
nek0 2016-12-08 18:22:29 +01:00
parent 334dba9e48
commit 4e20d26c97
6 changed files with 137 additions and 47 deletions

View File

@ -33,7 +33,7 @@ flag examples
library library
exposed-modules: Affection exposed-modules: Affection
-- , Affection.Render , Affection.Draw
, Affection.Types , Affection.Types
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
@ -56,6 +56,7 @@ library
, linear , linear
, mtl , mtl
, gegl , gegl
, babl
, monad-loops , monad-loops
, clock , clock
-- , sdl2-image -- , sdl2-image

View File

@ -71,7 +71,7 @@ load _ = do
, elapsedTime = 0 , elapsedTime = 0
} }
draw :: AffectionState (AffectionData UserData) IO () draw :: Affection UserData ()
draw = do draw = do
traceM "drawing" traceM "drawing"
AffectionData{..} <- get AffectionData{..} <- get
@ -95,7 +95,7 @@ draw = do
liftIO $ SDL.unlockSurface drawSurface liftIO $ SDL.unlockSurface drawSurface
liftIO $ SDL.updateWindowSurface drawWindow liftIO $ SDL.updateWindowSurface drawWindow
update :: Double -> AffectionState (AffectionData UserData) IO () update :: Double -> Affection UserData ()
update sec = do update sec = do
traceM "updating" traceM "updating"
-- liftIO $ delaySec 5 -- liftIO $ delaySec 5

View File

@ -67,44 +67,44 @@ load _ = do
, ("foreground" , bufsrc) , ("foreground" , bufsrc)
] ]
let roi = G.GeglRectangle 0 0 20 20 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" traceM "loading complete"
return $ UserData return $ UserData
{ nodeGraph = myMap { nodeGraph = myMap
@ -112,7 +112,7 @@ load _ = do
, elapsedTime = 0 , elapsedTime = 0
} }
draw :: AffectionState (AffectionData UserData) IO () draw :: Affection UserData ()
draw = do draw = do
traceM "drawing" traceM "drawing"
AffectionData{..} <- get AffectionData{..} <- get
@ -125,6 +125,7 @@ draw = do
format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8) format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8)
SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface
let (w, h) = (fromIntegral rw, fromIntegral rh) 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 liftIO $ G.gegl_node_blit
(nodeGraph M.! "over" :: G.GeglNode) (nodeGraph M.! "over" :: G.GeglNode)
1 1

View File

@ -6,10 +6,11 @@ module Affection
, delaySec , delaySec
, get , get
, put , put
, module Types , module A
) where ) where
import qualified SDL import qualified SDL
import qualified SDL.Internal.Numbered as SDL (toNumber)
import qualified SDL.Raw as Raw import qualified SDL.Raw as Raw
import qualified GEGL as G import qualified GEGL as G
@ -22,7 +23,8 @@ import Control.Monad.Loops
import Control.Monad.State import Control.Monad.State
import Control.Concurrent.MVar 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. -- | Main function which bootstraps everything else.
withAffection withAffection
@ -46,10 +48,10 @@ withAffection AffectionConfig{..} = do
, drawWindow = window , drawWindow = window
, drawSurface = surface , drawSurface = surface
}) =<< loadState surface }) =<< loadState surface
(_, nState) <- runStateT ( Types.runState $ (_, nState) <- runStateT ( A.runState $
whileM_ (do whileM_ (do
current <- get current <- get
return $ not $ Types.quitEvent current return $ not $ A.quitEvent current
) )
(do (do
now <- liftIO $ getTime Monotonic now <- liftIO $ getTime Monotonic

71
src/Affection/Draw.hs Normal file
View File

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

View File

@ -1,6 +1,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
module Affection.Types module Affection.Types
( AffectionData(..) ( Affection
, AffectionData(..)
, AffectionConfig(..) , AffectionConfig(..)
, AffectionState(..) , AffectionState(..)
-- , AffectionDraw(..) -- , AffectionDraw(..)
@ -10,15 +11,20 @@ module Affection.Types
, InitComponents(..) , InitComponents(..)
-- , Loop(..) -- , Loop(..)
, RGBA(..) , RGBA(..)
, DrawType(..)
, SDL.WindowConfig(..) , SDL.WindowConfig(..)
, SDL.defaultWindow , SDL.defaultWindow
-- | Convenience exports -- | Convenience exports
, liftIO , liftIO
-- | GEGL reexports
, G.GeglRectangle(..)
, G.GeglBuffer(..)
) where ) where
import qualified SDL.Init as SDL import qualified SDL.Init as SDL
import qualified SDL.Video as SDL import qualified SDL.Video as SDL
import qualified Data.Text as T import qualified Data.Text as T
import qualified GEGL as G
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.State import Control.Monad.State
@ -71,6 +77,8 @@ newtype AffectionState us m a = AffectionState
{ runState :: AffectionStateInner us m a } { runState :: AffectionStateInner us m a }
deriving (Functor, Applicative, Monad, MonadIO, MonadState us) deriving (Functor, Applicative, Monad, MonadIO, MonadState us)
type Affection us a = AffectionState (AffectionData us) IO a
-- -- | Inner 'StateT' monad of Affection -- -- | Inner 'StateT' monad of Affection
-- type AffectionInner us od a = StateT (AffectionState us od) IO a -- type AffectionInner us od a = StateT (AffectionState us od) IO a
-- --
@ -98,3 +106,10 @@ data RGBA = RGBA
, b :: Int , b :: Int
, a :: 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
}