{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}
module Graphics.Rasterific
(
fill
, fillWithMethod
, renderMeshPatch
, stroke
, dashedStroke
, dashedStrokeWithOffset
, printTextAt
, printTextRanges
, withTexture
, withClipping
, withGroupOpacity
, withTransformation
, withPathOrientation
, TextRange( .. )
, PointSize( .. )
, ModulablePixel
, RenderablePixel
, renderDrawing
, renderDrawingAtDpi
, renderDrawingAtDpiToPDF
, renderDrawingsAtDpiToPDF
, renderOrdersAtDpiToPdf
, pathToPrimitives
, Texture
, Drawing
, Modulable
, V2( .. )
, Point
, Vector
, CubicBezier( .. )
, Line( .. )
, Bezier( .. )
, Primitive( .. )
, Path( .. )
, PathCommand( .. )
, Primitivable( .. )
, Geometry( .. )
, Transformable( .. )
, PointFoldable( .. )
, PlaneBoundable( .. )
, PlaneBound( .. )
, boundWidth
, boundHeight
, boundLowerLeftCorner
, line
, rectangle
, roundedRectangle
, circle
, ellipse
, polyline
, polygon
, drawImageAtSize
, drawImage
, cacheDrawing
, clip
, bezierFromPath
, lineFromPath
, cubicBezierFromPath
, firstTangeantOf
, lastTangeantOf
, firstPointOf
, lastPointOf
, Direction( .. )
, arcInDirection
, Join( .. )
, Cap( .. )
, SamplerRepeat( .. )
, FillMethod( .. )
, PatchInterpolation( .. )
, DashPattern
, drawOrdersOfDrawing
, dumpDrawing
) where
import Data.Monoid( (<>) )
import Control.Monad.Free( Free( .. ), liftF )
import Control.Monad.Free.Church( fromF )
import Control.Monad.ST( ST, runST )
import Control.Monad.State( modify, execState )
import Data.Maybe( fromMaybe )
import Codec.Picture.Types( Image( .. )
, Pixel( .. )
, PixelRGBA8
, pixelMapXY )
import qualified Data.ByteString.Lazy as LB
import qualified Data.Vector as V
import Graphics.Rasterific.Compositor
import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^-^) )
import Graphics.Rasterific.Rasterize
import Graphics.Rasterific.MicroPdf
import Graphics.Rasterific.ComplexPrimitive
import Graphics.Rasterific.Types
import Graphics.Rasterific.Line
import Graphics.Rasterific.QuadraticBezier
import Graphics.Rasterific.CubicBezier
import Graphics.Rasterific.StrokeInternal
import Graphics.Rasterific.Transformations
import Graphics.Rasterific.PlaneBoundable
import Graphics.Rasterific.Immediate
import Graphics.Rasterific.PathWalker
import Graphics.Rasterific.Arc
import Graphics.Rasterific.Command
import Graphics.Rasterific.PatchTypes
import Graphics.Rasterific.Patch
import Graphics.Rasterific.MeshPatch
import Graphics.Text.TrueType( Font
, Dpi
, PointSize( .. )
)
withTexture :: Texture px -> Drawing px () -> Drawing px ()
withTexture texture subActions =
liftF $ SetTexture texture subActions ()
withGroupOpacity :: PixelBaseComponent px -> Drawing px ()-> Drawing px ()
withGroupOpacity opa sub = liftF $ WithGlobalOpacity opa sub ()
withTransformation :: Transformation -> Drawing px () -> Drawing px ()
withTransformation trans sub =
liftF $ WithTransform trans sub ()
withPathOrientation :: Path
-> Float
-> Drawing px ()
-> Drawing px ()
withPathOrientation path p sub =
liftF $ WithPathOrientation path p sub ()
fill :: Geometry geom => geom -> Drawing px ()
fill prims = liftF $ Fill FillWinding (toPrimitives prims) ()
fillWithMethod :: Geometry geom
=> FillMethod -> geom -> Drawing px ()
fillWithMethod method prims =
liftF $ Fill method (toPrimitives prims) ()
withClipping
:: (forall innerPixel. Drawing innerPixel ())
-> Drawing px ()
-> Drawing px ()
withClipping clipPath drawing =
liftF $ WithCliping clipPath drawing ()
stroke :: (Geometry geom)
=> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
stroke width join caping prims =
liftF $ Stroke width join caping (toPrimitives prims) ()
printTextAt :: Font
-> PointSize
-> Point
-> String
-> Drawing px ()
printTextAt font pointSize point string =
liftF $ TextFill point [description] ()
where
description = TextRange
{ _textFont = font
, _textSize = pointSize
, _text = string
, _textTexture = Nothing
}
renderMeshPatch :: PatchInterpolation -> MeshPatch px -> Drawing px ()
renderMeshPatch i mesh = liftF $ MeshPatchRender i mesh ()
printTextRanges :: Point
-> [TextRange px]
-> Drawing px ()
printTextRanges point ranges = liftF $ TextFill point ranges ()
data RenderContext px = RenderContext
{ currentClip :: Maybe (Texture (PixelBaseComponent px))
, currentTexture :: Texture px
, currentTransformation :: Maybe (Transformation, Transformation)
}
renderDrawing
:: forall px . (RenderablePixel px)
=> Int
-> Int
-> px
-> Drawing px ()
-> Image px
renderDrawing width height = renderDrawingAtDpi width height 96
renderOrdersAtDpiToPdf
:: Int
-> Int
-> Dpi
-> [DrawOrder PixelRGBA8]
-> LB.ByteString
renderOrdersAtDpiToPdf w h dpi =
renderOrdersToPdf renderer w h dpi
where
renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px]
renderer = drawOrdersOfDrawing w h dpi emptyPx
renderDrawingAtDpiToPDF
:: Int
-> Int
-> Dpi
-> Drawing PixelRGBA8 ()
-> LB.ByteString
renderDrawingAtDpiToPDF w h dpi d = renderDrawingsAtDpiToPDF w h dpi [d]
renderDrawingsAtDpiToPDF
:: Int
-> Int
-> Dpi
-> [Drawing PixelRGBA8 ()]
-> LB.ByteString
renderDrawingsAtDpiToPDF w h dpi =
renderDrawingsToPdf renderer w h dpi
where
renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px]
renderer = drawOrdersOfDrawing w h dpi emptyPx
renderDrawingAtDpi
:: forall px . (RenderablePixel px)
=> Int
-> Int
-> Dpi
-> px
-> Drawing px ()
-> Image px
renderDrawingAtDpi width height dpi background drawing =
runST $ runDrawContext width height background
$ mapM_ fillOrder
$ drawOrdersOfDrawing width height dpi background drawing
cacheOrders :: forall px. (RenderablePixel px)
=> Maybe (Image px -> ImageTransformer px)
-> Int
-> Int
-> [DrawOrder px] -> Drawing px ()
cacheOrders imageFilter maxWidth maxHeight orders = case imageFilter of
Nothing -> drawImageAtSize resultImage 0 cornerUpperLeft width height
Just f -> drawImage (pixelMapXY (f resultImage) resultImage) 0 cornerUpperLeft
where
PlaneBound mini maxi = foldMap planeBounds orders
cornerUpperLeftInt = floor <$> mini :: V2 Int
cornerUpperLeft = fromIntegral <$> cornerUpperLeftInt
V2 width height = min <$> (maxi ^-^ cornerUpperLeft ^+^ V2 1 1)
<*> (V2 (fromIntegral maxWidth) (fromIntegral maxHeight))
shiftOrder order@DrawOrder { _orderPrimitives = prims } =
order { _orderPrimitives = fmap (transform (^-^ cornerUpperLeft)) <$> prims
, _orderTexture =
WithTextureTransform (translate cornerUpperLeft) $ _orderTexture order
, _orderMask =
WithTextureTransform (translate cornerUpperLeft) <$> _orderMask order
}
resultImage =
runST $ runDrawContext (ceiling width) (ceiling height) emptyPx
$ mapM_ (fillOrder . shiftOrder) orders
cacheDrawing
:: forall px . (RenderablePixel px)
=> Int
-> Int
-> Dpi
-> Drawing px ()
-> Drawing px ()
cacheDrawing maxWidth maxHeight dpi sub =
cacheOrders Nothing maxWidth maxHeight $
drawOrdersOfDrawing maxWidth maxHeight dpi emptyPx sub
drawOrdersOfDrawing
:: forall px . (RenderablePixel px)
=> Int
-> Int
-> Dpi
-> px
-> Drawing px ()
-> [DrawOrder px]
drawOrdersOfDrawing width height dpi background drawing =
go initialContext (fromF drawing) []
where
initialContext = RenderContext Nothing stupidDefaultTexture Nothing
clipBackground = emptyValue :: PixelBaseComponent px
clipForeground = fullValue :: PixelBaseComponent px
clipRender ctxt =
renderDrawing width height clipBackground .
transformer .
withTexture (SolidTexture clipForeground)
where
transformer = maybe id (withTransformation . fst) $ currentTransformation ctxt
subRender :: (forall s. DrawContext (ST s) px ()) -> Image px
subRender act =
runST $ runDrawContext width height background act
textureOf ctxt@RenderContext { currentTransformation = Just (_, t) } =
WithTextureTransform t $ currentTexture ctxt
textureOf ctxt = currentTexture ctxt
geometryOf :: Transformable a => RenderContext px -> a -> a
geometryOf RenderContext { currentTransformation = Just (trans, _) } =
transform (applyTransformation trans)
geometryOf _ = id
geometryOfO RenderContext { currentTransformation = Just (trans, _) } =
transformOrder (applyTransformation trans)
geometryOfO _ = id
stupidDefaultTexture =
SolidTexture $ colorMap (const clipBackground) background
orderOf ctxt method primitives = DrawOrder
{ _orderPrimitives = primitives
, _orderTexture = textureOf ctxt
, _orderFillMethod = method
, _orderMask = currentClip ctxt
, _orderDirect = return ()
}
go :: RenderContext px -> Free (DrawCommand px) () -> [DrawOrder px]
-> [DrawOrder px]
go _ (Pure ()) rest = rest
go ctxt (Free (WithGlobalOpacity opa sub next)) rest =
go ctxt (Free (WithImageEffect opacifier sub next)) rest
where
opacifier _ _ _ px = mixWithAlpha ignore alphaModulate px px
ignore _ _ a = a
alphaModulate _ v = opa `modulate` v
go ctxt (Free (WithImageEffect effect sub next)) rest =
go freeContext (fromF cached) after
where
cached = cacheOrders (Just effect) maxBound maxBound $ go ctxt (fromF sub) []
after = go ctxt next rest
freeContext = ctxt { currentClip = Nothing, currentTransformation = Nothing }
go ctxt (Free (WithPathOrientation path base sub next)) rest = final where
final = orders <> go ctxt next rest
images = go ctxt (fromF sub) []
drawer trans _ order =
modify (transformOrder (applyTransformation trans) order :)
orders = reverse $ execState (drawOrdersOnPath drawer 0 base path images) []
go ctxt (Free (WithTransform trans sub next)) rest = final where
trans'
| Just (t, _) <- currentTransformation ctxt = t <> trans
| otherwise = trans
invTrans = fromMaybe mempty $ inverseTransformation trans'
after = go ctxt next rest
subContext =
ctxt { currentTransformation = Just (trans', invTrans) }
final = go subContext (fromF sub) after
go ctxt (Free (CustomRender cust next)) rest = order : after where
after = go ctxt next rest
order = DrawOrder
{ _orderPrimitives = []
, _orderTexture = textureOf ctxt
, _orderFillMethod = FillWinding
, _orderMask = currentClip ctxt
, _orderDirect = cust
}
go ctxt (Free (MeshPatchRender i mesh next)) rest = order : after where
after = go ctxt next rest
rendering :: DrawContext (ST s) px ()
rendering = case i of
PatchBilinear -> mapM_ rasterizeCoonPatch $ coonPatchesOf $ geometryOf ctxt opaqueMesh
PatchBicubic ->
mapM_ rasterizeCoonPatch
. cubicCoonPatchesOf
$ calculateMeshColorDerivative $ geometryOf ctxt opaqueMesh
hasTransparency =
V.any ((/= fullValue) . pixelOpacity) $ _meshColors mesh
opacifier px = mixWithAlpha (\_ _ a -> a) (\_ _ -> fullValue) px px
opaqueMesh = opacifier <$> mesh
transparencyMesh = pixelOpacity <$> mesh
clipPath
| not hasTransparency = currentClip ctxt
| otherwise =
let newMask :: Image (PixelBaseComponent (PixelBaseComponent px))
newMask = clipRender ctxt $ renderMeshPatch i transparencyMesh in
case currentClip ctxt of
Nothing -> Just $ RawTexture newMask
Just v -> Just $ ModulateTexture v (RawTexture newMask)
order = case clipPath of
Nothing -> DrawOrder
{ _orderPrimitives = []
, _orderTexture = textureOf ctxt
, _orderFillMethod = FillWinding
, _orderMask = clipPath
, _orderDirect = rendering
}
Just c -> DrawOrder
{ _orderPrimitives = [geometryOf ctxt $ rectangle (V2 0 0) (fromIntegral width) (fromIntegral height)]
, _orderTexture = AlphaModulateTexture (RawTexture $ subRender rendering) c
, _orderFillMethod = FillWinding
, _orderMask = Nothing
, _orderDirect = return ()
}
go ctxt (Free (Fill method prims next)) rest = order : after where
after = go ctxt next rest
order = orderOf ctxt method [geometryOf ctxt prims >>= listOfContainer . sanitizeFilling]
go ctxt (Free (Stroke w j cap prims next)) rest = order : after where
after = go ctxt next rest
order = orderOf ctxt FillWinding [geometryOf ctxt prim']
prim' = listOfContainer $ strokize w j cap prims
go ctxt (Free (SetTexture tx sub next)) rest =
go (ctxt { currentTexture = tx }) (fromF sub) $
go ctxt next rest
go ctxt (Free (DashedStroke o d w j cap prims next)) rest =
foldr recurse after $ dashedStrokize o d w j cap prims
where
after = go ctxt next rest
recurse sub =
go ctxt (liftF $ Fill FillWinding sub ())
go ctxt (Free (TextFill p descriptions next)) rest = calls <> go ctxt next rest where
calls =
geometryOfO ctxt <$> textToDrawOrders dpi (currentTexture ctxt) p descriptions
go ctxt (Free (WithCliping clipPath path next)) rest =
go (ctxt { currentClip = newModuler }) (fromF path) $
go ctxt next rest
where
modulationTexture :: Texture (PixelBaseComponent px)
modulationTexture = RawTexture $ clipRender ctxt clipPath
newModuler = Just . subModuler $ currentClip ctxt
subModuler Nothing = modulationTexture
subModuler (Just v) =
ModulateTexture v modulationTexture
dashedStroke
:: Geometry geom
=> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
dashedStroke = dashedStrokeWithOffset 0.0
dashedStrokeWithOffset
:: Geometry geom
=> Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
dashedStrokeWithOffset _ [] width join caping prims =
stroke width join caping prims
dashedStrokeWithOffset offset dashing width join caping prims =
liftF $ DashedStroke offset dashing width join caping (toPrimitives prims) ()
polyline :: [Point] -> [Primitive]
polyline = map LinePrim . lineFromPath
polygon :: [Point] -> [Primitive]
polygon [] = []
polygon [_] = []
polygon [_,_] = []
polygon lst@(p:_) = polyline $ lst ++ [p]
drawImage :: Image px
-> StrokeWidth
-> Point
-> Drawing px ()
drawImage img@Image { imageWidth = w, imageHeight = h } s p =
drawImageAtSize img s p (fromIntegral w) (fromIntegral h)
drawImageAtSize :: Image px
-> StrokeWidth
-> Point
-> Float
-> Float
-> Drawing px ()
drawImageAtSize img@Image { imageWidth = w, imageHeight = h } borderSize ip
reqWidth reqHeight
| borderSize <= 0 =
withTransformation (translate p <> scale scaleX scaleY) .
withTexture (SampledTexture img) $ fill rect
| otherwise = do
withTransformation (translate p <> scale scaleX scaleY) $
withTexture (SampledTexture img) $ fill rect
stroke (borderSize / 2) (JoinMiter 0)
(CapStraight 0, CapStraight 0) rect'
where
p = ip ^-^ V2 0.5 0.5
rect = rectangle (V2 0 0) rw rh
rect' = rectangle p reqWidth reqHeight
(rw, rh) = (fromIntegral w, fromIntegral h)
scaleX | reqWidth == 0 = 1
| otherwise = reqWidth / rw
scaleY | reqHeight == 0 = 1
| otherwise = reqHeight / rh
line :: Point -> Point -> [Primitive]
line p1 p2 = [LinePrim $ Line p1 p2]