module Graphics.Rasterific.Immediate
( DrawContext
, DrawOrder( .. )
, orderToDrawing
, runDrawContext
, fillWithTextureAndMask
, fillWithTexture
, fillOrder
) where
import qualified Data.Foldable as F
import Control.Monad.Free( liftF )
import Control.Monad.ST( ST )
import Control.Monad.State( StateT, execStateT, get, lift )
import Codec.Picture.Types( Image( .. )
, Pixel( .. )
, Pixel8
, PixelRGBA8
, MutableImage( .. )
, unsafeFreezeImage
, fillImageWith )
import Control.Monad.Primitive( PrimState, PrimMonad, primToPrim )
import qualified Data.Vector.Storable.Mutable as M
import Graphics.Rasterific.Compositor
import Graphics.Rasterific.Linear( V2( .. ) )
import Graphics.Rasterific.Rasterize
import Graphics.Rasterific.Texture
import Graphics.Rasterific.Shading
import Graphics.Rasterific.Types
import Graphics.Rasterific.Command
type DrawContext m px a =
StateT (MutableImage (PrimState m) px) m a
data DrawOrder px = DrawOrder
{
_orderPrimitives :: ![[Primitive]]
, _orderTexture :: !(Texture px)
, _orderFillMethod :: !FillMethod
, _orderMask :: !(Maybe (Texture (PixelBaseComponent px)))
}
orderToDrawing :: DrawOrder px -> Drawing px ()
orderToDrawing order =
usingTexture . mapM_ filler $ _orderPrimitives order
where
usingTexture sub =
liftF $ SetTexture (_orderTexture order) sub ()
filler prims =
liftF $ Fill (_orderFillMethod order) prims ()
fillOrder :: (PrimMonad m, RenderablePixel px)
=> DrawOrder px -> DrawContext m px ()
fillOrder o@DrawOrder { _orderMask = Nothing } =
F.forM_ (_orderPrimitives o) $
fillWithTexture (_orderFillMethod o) (_orderTexture o)
fillOrder o@DrawOrder { _orderMask = Just mask } =
F.forM_ (_orderPrimitives o) $
fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask
runDrawContext :: forall m px . (PrimMonad m, RenderablePixel px)
=> Int
-> Int
-> px
-> DrawContext m px ()
-> m (Image px)
runDrawContext width height background drawing = do
buff <- M.new (width * height * componentCount background)
let mutable = MutableImage width height buff
fillImageWith mutable background
img <- execStateT drawing mutable
unsafeFreezeImage img
mapExec :: Monad m => (a -> m ()) -> [a] -> m ()
mapExec f = foldr ((>>) . f) (return ())
isCoverageDrawable :: MutableImage s px -> CoverageSpan -> Bool
isCoverageDrawable img coverage =
_coverageVal coverage > 0 && x >= 0 && y >= 0 && x < imgWidth && y < imgHeight
where
!imgWidth = fromIntegral $ mutableImageWidth img
!imgHeight = fromIntegral $ mutableImageHeight img
x = _coverageX coverage
y = _coverageY coverage
fillWithTexture :: (PrimMonad m, RenderablePixel px)
=> FillMethod
-> Texture px
-> [Primitive]
-> DrawContext m px ()
fillWithTexture fillMethod texture els = do
img@(MutableImage width height _) <- get
let !mini = V2 0 0
!maxi = V2 (fromIntegral width) (fromIntegral height)
!filler = primToPrim . transformTextureToFiller texture img
clipped = F.foldMap (clip mini maxi) els
spans = rasterize fillMethod clipped
lift . mapExec filler $ filter (isCoverageDrawable img) spans
fillWithTextureAndMask
:: (PrimMonad m, RenderablePixel px)
=> FillMethod
-> Texture px
-> Texture (PixelBaseComponent px)
-> [Primitive]
-> DrawContext m px ()
fillWithTextureAndMask fillMethod texture mask els = do
img@(MutableImage width height _) <- get
let !mini = V2 0 0
!maxi = V2 (fromIntegral width) (fromIntegral height)
spans = rasterize fillMethod $ F.foldMap (clip mini maxi) els
!shader = primToPrim
. transformTextureToFiller (modulateTexture texture mask) img
lift . mapM_ shader $ filter (isCoverageDrawable img) spans