79 lines
2.5 KiB
Haskell
79 lines
2.5 KiB
Haskell
{-# 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
|
|
-> 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
|
|
)
|
|
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)
|
|
drawRect buf color Fill (G.GeglRectangle (rectangleX + rectangleWidth - size) rectangleY size rectangleHeight)
|
|
drawRect buf color Fill (G.GeglRectangle rectangleX (rectangleY + rectangleHeight - size) rectangleWidth size)
|
|
|
|
-- | 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
|
|
)
|