vulkan-tutorial/src/Affection/Draw.hs

95 lines
2.9 KiB
Haskell
Raw Normal View History

2016-12-08 17:22:29 +00:00
{-# LANGUAGE RecordWildCards #-}
-- | Module for drawing primitives
module Affection.Draw
( drawRect
2016-12-11 11:24:02 +00:00
-- , clear
, clearArea
2016-12-08 17:22:29 +00:00
) 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
-> IO ()
drawRect buf color (Fill) rect@G.GeglRectangle{..} =
G.pixelPoke buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $
(\(x, y) ->
let col = unsafeColorize color
in
G.Pixel x y col
2016-12-08 17:22:29 +00:00
)
drawRect buf color (Line size) rect@G.GeglRectangle{..} = do
drawRect buf color Fill (G.GeglRectangle rectangleX rectangleY rectangleWidth size)
drawRect buf color Fill (G.GeglRectangle rectangleX rectangleY size rectangleHeight)
2016-12-11 00:42:06 +00:00
drawRect buf color Fill (G.GeglRectangle (rectangleX + rectangleWidth - size) rectangleY size rectangleHeight)
drawRect buf color Fill (G.GeglRectangle rectangleX (rectangleY + rectangleHeight - size) rectangleWidth size)
2016-12-08 17:22:29 +00:00
-- | 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
)
unsafeColorize col =
let
(r, g, b) = case col of
G.RGBA cr cg cb _ -> (cr, cg, cb)
G.RGB cr cg cb -> (cr, cg, cb)
a = case col of
G.RGBA _ _ _ ca -> ca
G.RGB _ _ _ -> 1
in
( G.CVdouble $ CDouble $ r
, G.CVdouble $ CDouble $ g
, G.CVdouble $ CDouble $ b
, G.CVdouble $ CDouble $ a
)
2016-12-11 11:24:02 +00:00
-- -- | Clear all data from a buffer
-- clear
-- :: G.GeglBuffer -- ^ Target buffer
-- -> IO ()
-- clear buf = clearArea buf =<< G.gegl_rectangle_infinite_plane
-- | Clear a specified area of a buffer from all data
clearArea
:: G.GeglBuffer -- ^ Target buffer
-> G.GeglRectangle -- ^ Area to clear
-> IO ()
clearArea = G.gegl_buffer_clear