module Graphics.Rasterific.Immediate
( DrawContext
, DrawOrder( .. )
, orderToDrawing
, runDrawContext
, fillWithTextureAndMask
, fillWithTexture
, fillWithTextureNoAA
, fillOrder
, textToDrawOrders
, transformOrder
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( (<$>) )
import Data.Foldable( foldMap )
#endif
import Control.Monad.ST( ST )
import Data.Maybe( fromMaybe )
import qualified Data.Foldable as F
import Control.Monad.Free( liftF )
import Control.Monad.State( evalStateT, execStateT, lift )
import Control.Monad.Trans.State( get )
import Codec.Picture.Types( Image( .. )
, Pixel( .. )
, MutableImage( .. )
, unsafeFreezeImage
, fillImageWith )
import Control.Monad.Primitive( 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.Shading
import Graphics.Rasterific.QuadraticBezier
import Graphics.Rasterific.Types
import Graphics.Rasterific.Command
import Graphics.Rasterific.PlaneBoundable
import qualified Data.Vector.Unboxed as VU
import Graphics.Text.TrueType( Dpi, getStringCurveAtPoint )
data DrawOrder px = DrawOrder
{
_orderPrimitives :: ![[Primitive]]
, _orderTexture :: !(Texture px)
, _orderFillMethod :: !FillMethod
, _orderMask :: !(Maybe (Texture (PixelBaseComponent px)))
, _orderDirect :: !(forall s. DrawContext (ST s) px ())
}
instance PlaneBoundable (DrawOrder px) where
planeBounds =
foldMap (foldMap planeBounds) . _orderPrimitives
transformOrder :: (Point -> Point) -> DrawOrder px -> DrawOrder px
transformOrder f order =
order { _orderPrimitives = transform f $ _orderPrimitives order }
transformOrderM :: Monad m => (Point -> m Point) -> DrawOrder px -> m (DrawOrder px)
transformOrderM f order = do
v <- transformM f $ _orderPrimitives order
return $ order { _orderPrimitives = v}
instance Transformable (DrawOrder px) where
transform = transformOrder
transformM = transformOrderM
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 } = do
F.forM_ (_orderPrimitives o) $
fillWithTexture (_orderFillMethod o) (_orderTexture o)
img <- get
lift $ primToPrim $ flip evalStateT img $ _orderDirect o
fillOrder o@DrawOrder { _orderMask = Just mask } = do
F.forM_ (_orderPrimitives o) $
fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask
img <- get
lift $ primToPrim $ flip evalStateT img $ _orderDirect o
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 = foldMap (clip mini maxi) els
spans = rasterize fillMethod clipped
lift . mapExec filler $ filter (isCoverageDrawable img) spans
fillWithTextureNoAA :: (PrimMonad m, RenderablePixel px)
=> FillMethod
-> Texture px
-> [Primitive]
-> DrawContext m px ()
fillWithTextureNoAA 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 = foldMap (clip mini maxi) els
spans = rasterize fillMethod clipped
lift . mapExec (filler . toOpaqueCoverage) $ 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 $ foldMap (clip mini maxi) els
!shader = primToPrim
. transformTextureToFiller (ModulateTexture texture mask) img
lift . mapM_ shader $ filter (isCoverageDrawable img) spans
textToDrawOrders :: Dpi
-> Texture px
-> Point
-> [TextRange px]
-> [DrawOrder px]
textToDrawOrders dpi defaultTexture (V2 x y) descriptions =
toOrder <$> zip floatCurves linearDescriptions where
toOrder (curve, d) = DrawOrder
{ _orderPrimitives = [beziersOfChar curve]
, _orderFillMethod = FillWinding
, _orderMask = Nothing
, _orderTexture = fromMaybe defaultTexture $ _textTexture d
, _orderDirect = return ()
}
floatCurves =
getStringCurveAtPoint dpi (x, y)
[(_textFont d, _textSize d, _text d) | d <- descriptions]
linearDescriptions =
concat [map (const d) $ _text d | d <- descriptions]
beziersOfChar curves = concat
[fmap BezierPrim . bezierFromPath . fmap (uncurry V2) $ VU.toList c | c <- curves]