{-# 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 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 px -> Drawing px () -> Drawing px ()
withTexture Texture px
texture Drawing px ()
subActions =
DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Texture px -> Drawing px () -> () -> DrawCommand px ()
forall px next.
Texture px -> Drawing px () -> next -> DrawCommand px next
SetTexture Texture px
texture Drawing px ()
subActions ()
withGroupOpacity :: PixelBaseComponent px -> Drawing px ()-> Drawing px ()
withGroupOpacity :: PixelBaseComponent px -> Drawing px () -> Drawing px ()
withGroupOpacity PixelBaseComponent px
opa Drawing px ()
sub = DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ PixelBaseComponent px -> Drawing px () -> () -> DrawCommand px ()
forall px next.
PixelBaseComponent px
-> Drawing px () -> next -> DrawCommand px next
WithGlobalOpacity PixelBaseComponent px
opa Drawing px ()
sub ()
withTransformation :: Transformation -> Drawing px () -> Drawing px ()
withTransformation :: Transformation -> Drawing px () -> Drawing px ()
withTransformation Transformation
trans Drawing px ()
sub =
DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Transformation -> Drawing px () -> () -> DrawCommand px ()
forall px next.
Transformation -> Drawing px () -> next -> DrawCommand px next
WithTransform Transformation
trans Drawing px ()
sub ()
withPathOrientation :: Path
-> Float
-> Drawing px ()
-> Drawing px ()
withPathOrientation :: Path -> Float -> Drawing px () -> Drawing px ()
withPathOrientation Path
path Float
p Drawing px ()
sub =
DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Path -> Float -> Drawing px () -> () -> DrawCommand px ()
forall px next.
Path -> Float -> Drawing px () -> next -> DrawCommand px next
WithPathOrientation Path
path Float
p Drawing px ()
sub ()
fill :: Geometry geom => geom -> Drawing px ()
fill :: geom -> Drawing px ()
fill geom
prims = DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ FillMethod -> [Primitive] -> () -> DrawCommand px ()
forall px next.
FillMethod -> [Primitive] -> next -> DrawCommand px next
Fill FillMethod
FillWinding (geom -> [Primitive]
forall a. Geometry a => a -> [Primitive]
toPrimitives geom
prims) ()
fillWithMethod :: Geometry geom
=> FillMethod -> geom -> Drawing px ()
fillWithMethod :: FillMethod -> geom -> Drawing px ()
fillWithMethod FillMethod
method geom
prims =
DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ FillMethod -> [Primitive] -> () -> DrawCommand px ()
forall px next.
FillMethod -> [Primitive] -> next -> DrawCommand px next
Fill FillMethod
method (geom -> [Primitive]
forall a. Geometry a => a -> [Primitive]
toPrimitives geom
prims) ()
withClipping
:: (forall innerPixel. Drawing innerPixel ())
-> Drawing px ()
-> Drawing px ()
withClipping :: (forall innerPixel. Drawing innerPixel ())
-> Drawing px () -> Drawing px ()
withClipping forall innerPixel. Drawing innerPixel ()
clipPath Drawing px ()
drawing =
DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ (forall innerPixel. Drawing innerPixel ())
-> Drawing px () -> () -> DrawCommand px ()
forall px next.
(forall innerPixel. Drawing innerPixel ())
-> Drawing px () -> next -> DrawCommand px next
WithCliping forall innerPixel. Drawing innerPixel ()
clipPath Drawing px ()
drawing ()
stroke :: (Geometry geom)
=> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
stroke :: Float -> Join -> (Cap, Cap) -> geom -> Drawing px ()
stroke Float
width Join
join (Cap, Cap)
caping geom
prims =
DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Float
-> Join -> (Cap, Cap) -> [Primitive] -> () -> DrawCommand px ()
forall px next.
Float
-> Join -> (Cap, Cap) -> [Primitive] -> next -> DrawCommand px next
Stroke Float
width Join
join (Cap, Cap)
caping (geom -> [Primitive]
forall a. Geometry a => a -> [Primitive]
toPrimitives geom
prims) ()
printTextAt :: Font
-> PointSize
-> Point
-> String
-> Drawing px ()
printTextAt :: Font -> PointSize -> Point -> String -> Drawing px ()
printTextAt Font
font PointSize
pointSize Point
point String
string =
DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Point -> [TextRange px] -> () -> DrawCommand px ()
forall px next.
Point -> [TextRange px] -> next -> DrawCommand px next
TextFill Point
point [TextRange px
description] ()
where
description :: TextRange px
description = TextRange :: forall px.
Font -> PointSize -> String -> Maybe (Texture px) -> TextRange px
TextRange
{ _textFont :: Font
_textFont = Font
font
, _textSize :: PointSize
_textSize = PointSize
pointSize
, _text :: String
_text = String
string
, _textTexture :: Maybe (Texture px)
_textTexture = Maybe (Texture px)
forall a. Maybe a
Nothing
}
renderMeshPatch :: PatchInterpolation -> MeshPatch px -> Drawing px ()
renderMeshPatch :: PatchInterpolation -> MeshPatch px -> Drawing px ()
renderMeshPatch PatchInterpolation
i MeshPatch px
mesh = DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ PatchInterpolation -> MeshPatch px -> () -> DrawCommand px ()
forall px next.
PatchInterpolation -> MeshPatch px -> next -> DrawCommand px next
MeshPatchRender PatchInterpolation
i MeshPatch px
mesh ()
printTextRanges :: Point
-> [TextRange px]
-> Drawing px ()
Point
point [TextRange px]
ranges = DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Point -> [TextRange px] -> () -> DrawCommand px ()
forall px next.
Point -> [TextRange px] -> next -> DrawCommand px next
TextFill Point
point [TextRange px]
ranges ()
data RenderContext px = RenderContext
{ RenderContext px -> Maybe (Texture (PixelBaseComponent px))
currentClip :: Maybe (Texture (PixelBaseComponent px))
, RenderContext px -> Texture px
currentTexture :: Texture px
, RenderContext px -> Maybe (Transformation, Transformation)
currentTransformation :: Maybe (Transformation, Transformation)
}
renderDrawing
:: forall px . (RenderablePixel px)
=> Int
-> Int
-> px
-> Drawing px ()
-> Image px
renderDrawing :: Int -> Int -> px -> Drawing px () -> Image px
renderDrawing Int
width Int
height = Int -> Int -> Int -> px -> Drawing px () -> Image px
forall px.
RenderablePixel px =>
Int -> Int -> Int -> px -> Drawing px () -> Image px
renderDrawingAtDpi Int
width Int
height Int
96
renderOrdersAtDpiToPdf
:: Int
-> Int
-> Dpi
-> [DrawOrder PixelRGBA8]
-> LB.ByteString
renderOrdersAtDpiToPdf :: Int -> Int -> Int -> [DrawOrder PixelRGBA8] -> ByteString
renderOrdersAtDpiToPdf Int
w Int
h Int
dpi =
InnerRenderer
-> Int -> Int -> Int -> [DrawOrder PixelRGBA8] -> ByteString
renderOrdersToPdf forall px. RenderablePixel px => Drawing px () -> [DrawOrder px]
InnerRenderer
renderer Int
w Int
h Int
dpi
where
renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px]
renderer :: Drawing px () -> [DrawOrder px]
renderer = Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
forall px.
RenderablePixel px =>
Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
drawOrdersOfDrawing Int
w Int
h Int
dpi px
forall px. RenderablePixel px => px
emptyPx
renderDrawingAtDpiToPDF
:: Int
-> Int
-> Dpi
-> Drawing PixelRGBA8 ()
-> LB.ByteString
renderDrawingAtDpiToPDF :: Int -> Int -> Int -> Drawing PixelRGBA8 () -> ByteString
renderDrawingAtDpiToPDF Int
w Int
h Int
dpi Drawing PixelRGBA8 ()
d = Int -> Int -> Int -> [Drawing PixelRGBA8 ()] -> ByteString
renderDrawingsAtDpiToPDF Int
w Int
h Int
dpi [Drawing PixelRGBA8 ()
d]
renderDrawingsAtDpiToPDF
:: Int
-> Int
-> Dpi
-> [Drawing PixelRGBA8 ()]
-> LB.ByteString
renderDrawingsAtDpiToPDF :: Int -> Int -> Int -> [Drawing PixelRGBA8 ()] -> ByteString
renderDrawingsAtDpiToPDF Int
w Int
h Int
dpi =
InnerRenderer
-> Int -> Int -> Int -> [Drawing PixelRGBA8 ()] -> ByteString
renderDrawingsToPdf forall px. RenderablePixel px => Drawing px () -> [DrawOrder px]
InnerRenderer
renderer Int
w Int
h Int
dpi
where
renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px]
renderer :: Drawing px () -> [DrawOrder px]
renderer = Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
forall px.
RenderablePixel px =>
Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
drawOrdersOfDrawing Int
w Int
h Int
dpi px
forall px. RenderablePixel px => px
emptyPx
renderDrawingAtDpi
:: forall px . (RenderablePixel px)
=> Int
-> Int
-> Dpi
-> px
-> Drawing px ()
-> Image px
renderDrawingAtDpi :: Int -> Int -> Int -> px -> Drawing px () -> Image px
renderDrawingAtDpi Int
width Int
height Int
dpi px
background Drawing px ()
drawing =
(forall s. ST s (Image px)) -> Image px
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Image px)) -> Image px)
-> (forall s. ST s (Image px)) -> Image px
forall a b. (a -> b) -> a -> b
$ Int -> Int -> px -> DrawContext (ST s) px () -> ST s (Image px)
forall (m :: * -> *) px.
(PrimMonad m, RenderablePixel px) =>
Int -> Int -> px -> DrawContext m px () -> m (Image px)
runDrawContext Int
width Int
height px
background
(DrawContext (ST s) px () -> ST s (Image px))
-> DrawContext (ST s) px () -> ST s (Image px)
forall a b. (a -> b) -> a -> b
$ (DrawOrder px -> StateT (MutableImage s px) (ST s) ())
-> [DrawOrder px] -> StateT (MutableImage s px) (ST s) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DrawOrder px -> StateT (MutableImage s px) (ST s) ()
forall (m :: * -> *) px.
(PrimMonad m, RenderablePixel px) =>
DrawOrder px -> DrawContext m px ()
fillOrder
([DrawOrder px] -> StateT (MutableImage s px) (ST s) ())
-> [DrawOrder px] -> StateT (MutableImage s px) (ST s) ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
forall px.
RenderablePixel px =>
Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
drawOrdersOfDrawing Int
width Int
height Int
dpi px
background Drawing px ()
drawing
cacheOrders :: forall px. (RenderablePixel px)
=> Maybe (Image px -> ImageTransformer px)
-> Int
-> Int
-> [DrawOrder px] -> Drawing px ()
cacheOrders :: Maybe (Image px -> ImageTransformer px)
-> Int -> Int -> [DrawOrder px] -> Drawing px ()
cacheOrders Maybe (Image px -> ImageTransformer px)
imageFilter Int
maxWidth Int
maxHeight [DrawOrder px]
orders = case Maybe (Image px -> ImageTransformer px)
imageFilter of
Maybe (Image px -> ImageTransformer px)
Nothing -> Image px -> Float -> Point -> Float -> Float -> Drawing px ()
forall px.
Image px -> Float -> Point -> Float -> Float -> Drawing px ()
drawImageAtSize Image px
resultImage Float
0 Point
cornerUpperLeft Float
width Float
height
Just Image px -> ImageTransformer px
f -> Image px -> Float -> Point -> Drawing px ()
forall px. Image px -> Float -> Point -> Drawing px ()
drawImage (ImageTransformer px -> Image px -> Image px
forall a b.
(Pixel a, Pixel b) =>
(Int -> Int -> a -> b) -> Image a -> Image b
pixelMapXY (Image px -> ImageTransformer px
f Image px
resultImage) Image px
resultImage) Float
0 Point
cornerUpperLeft
where
PlaneBound Point
mini Point
maxi = (DrawOrder px -> PlaneBound) -> [DrawOrder px] -> PlaneBound
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DrawOrder px -> PlaneBound
forall a. PlaneBoundable a => a -> PlaneBound
planeBounds [DrawOrder px]
orders
cornerUpperLeftInt :: V2 Int
cornerUpperLeftInt = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int) -> Point -> V2 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point
mini :: V2 Int
cornerUpperLeft :: Point
cornerUpperLeft = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Float) -> V2 Int -> Point
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V2 Int
cornerUpperLeftInt
V2 Float
width Float
height = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float -> Float -> Float) -> Point -> V2 (Float -> Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Point
maxi Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
cornerUpperLeft Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
1 Float
1)
V2 (Float -> Float) -> Point -> Point
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxWidth) (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxHeight))
shiftOrder :: DrawOrder px -> DrawOrder px
shiftOrder order :: DrawOrder px
order@DrawOrder { _orderPrimitives :: forall px. DrawOrder px -> [[Primitive]]
_orderPrimitives = [[Primitive]]
prims } =
DrawOrder px
order { _orderPrimitives :: [[Primitive]]
_orderPrimitives = (Primitive -> Primitive) -> [Primitive] -> [Primitive]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Point -> Point) -> Primitive -> Primitive
forall a. Transformable a => (Point -> Point) -> a -> a
transform (Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
cornerUpperLeft)) ([Primitive] -> [Primitive]) -> [[Primitive]] -> [[Primitive]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Primitive]]
prims
, _orderTexture :: Texture px
_orderTexture =
Transformation -> Texture px -> Texture px
forall px. Transformation -> Texture px -> Texture px
WithTextureTransform (Point -> Transformation
translate Point
cornerUpperLeft) (Texture px -> Texture px) -> Texture px -> Texture px
forall a b. (a -> b) -> a -> b
$ DrawOrder px -> Texture px
forall px. DrawOrder px -> Texture px
_orderTexture DrawOrder px
order
, _orderMask :: Maybe (Texture (PixelBaseComponent px))
_orderMask =
Transformation
-> Texture (PixelBaseComponent px)
-> Texture (PixelBaseComponent px)
forall px. Transformation -> Texture px -> Texture px
WithTextureTransform (Point -> Transformation
translate Point
cornerUpperLeft) (Texture (PixelBaseComponent px)
-> Texture (PixelBaseComponent px))
-> Maybe (Texture (PixelBaseComponent px))
-> Maybe (Texture (PixelBaseComponent px))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawOrder px -> Maybe (Texture (PixelBaseComponent px))
forall px. DrawOrder px -> Maybe (Texture (PixelBaseComponent px))
_orderMask DrawOrder px
order
}
resultImage :: Image px
resultImage =
(forall s. ST s (Image px)) -> Image px
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Image px)) -> Image px)
-> (forall s. ST s (Image px)) -> Image px
forall a b. (a -> b) -> a -> b
$ Int -> Int -> px -> DrawContext (ST s) px () -> ST s (Image px)
forall (m :: * -> *) px.
(PrimMonad m, RenderablePixel px) =>
Int -> Int -> px -> DrawContext m px () -> m (Image px)
runDrawContext (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Float
width) (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Float
height) px
forall px. RenderablePixel px => px
emptyPx
(DrawContext (ST s) px () -> ST s (Image px))
-> DrawContext (ST s) px () -> ST s (Image px)
forall a b. (a -> b) -> a -> b
$ (DrawOrder px -> StateT (MutableImage s px) (ST s) ())
-> [DrawOrder px] -> StateT (MutableImage s px) (ST s) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DrawOrder px -> StateT (MutableImage s px) (ST s) ()
forall (m :: * -> *) px.
(PrimMonad m, RenderablePixel px) =>
DrawOrder px -> DrawContext m px ()
fillOrder (DrawOrder px -> StateT (MutableImage s px) (ST s) ())
-> (DrawOrder px -> DrawOrder px)
-> DrawOrder px
-> StateT (MutableImage s px) (ST s) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrawOrder px -> DrawOrder px
shiftOrder) [DrawOrder px]
orders
cacheDrawing
:: forall px . (RenderablePixel px)
=> Int
-> Int
-> Dpi
-> Drawing px ()
-> Drawing px ()
cacheDrawing :: Int -> Int -> Int -> Drawing px () -> Drawing px ()
cacheDrawing Int
maxWidth Int
maxHeight Int
dpi Drawing px ()
sub =
Maybe (Image px -> ImageTransformer px)
-> Int -> Int -> [DrawOrder px] -> Drawing px ()
forall px.
RenderablePixel px =>
Maybe (Image px -> ImageTransformer px)
-> Int -> Int -> [DrawOrder px] -> Drawing px ()
cacheOrders Maybe (Image px -> ImageTransformer px)
forall a. Maybe a
Nothing Int
maxWidth Int
maxHeight ([DrawOrder px] -> Drawing px ())
-> [DrawOrder px] -> Drawing px ()
forall a b. (a -> b) -> a -> b
$
Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
forall px.
RenderablePixel px =>
Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
drawOrdersOfDrawing Int
maxWidth Int
maxHeight Int
dpi px
forall px. RenderablePixel px => px
emptyPx Drawing px ()
sub
drawOrdersOfDrawing
:: forall px . (RenderablePixel px)
=> Int
-> Int
-> Dpi
-> px
-> Drawing px ()
-> [DrawOrder px]
drawOrdersOfDrawing :: Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
drawOrdersOfDrawing Int
width Int
height Int
dpi px
background Drawing px ()
drawing =
RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
initialContext (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
drawing) []
where
initialContext :: RenderContext px
initialContext = Maybe (Texture (PixelBaseComponent px))
-> Texture px
-> Maybe (Transformation, Transformation)
-> RenderContext px
forall px.
Maybe (Texture (PixelBaseComponent px))
-> Texture px
-> Maybe (Transformation, Transformation)
-> RenderContext px
RenderContext Maybe (Texture (PixelBaseComponent px))
forall a. Maybe a
Nothing Texture px
stupidDefaultTexture Maybe (Transformation, Transformation)
forall a. Maybe a
Nothing
clipBackground :: PixelBaseComponent px
clipBackground = PixelBaseComponent px
forall a. Modulable a => a
emptyValue :: PixelBaseComponent px
clipForeground :: PixelBaseComponent px
clipForeground = PixelBaseComponent px
forall a. Modulable a => a
fullValue :: PixelBaseComponent px
clipRender :: RenderContext px
-> Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px)
clipRender RenderContext px
ctxt =
Int
-> Int
-> PixelBaseComponent px
-> Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px)
forall px.
RenderablePixel px =>
Int -> Int -> px -> Drawing px () -> Image px
renderDrawing Int
width Int
height PixelBaseComponent px
clipBackground (Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px))
-> (Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ())
-> Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
transformer (Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ())
-> (Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ())
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Texture (PixelBaseComponent px)
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall px. Texture px -> Drawing px () -> Drawing px ()
withTexture (PixelBaseComponent px -> Texture (PixelBaseComponent px)
forall px. px -> Texture px
SolidTexture PixelBaseComponent px
clipForeground)
where
transformer :: Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
transformer = (Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ())
-> ((Transformation, Transformation)
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ())
-> Maybe (Transformation, Transformation)
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall a. a -> a
id (Transformation
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall px. Transformation -> Drawing px () -> Drawing px ()
withTransformation (Transformation
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ())
-> ((Transformation, Transformation) -> Transformation)
-> (Transformation, Transformation)
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Transformation, Transformation) -> Transformation
forall a b. (a, b) -> a
fst) (Maybe (Transformation, Transformation)
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ())
-> Maybe (Transformation, Transformation)
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall a b. (a -> b) -> a -> b
$ RenderContext px -> Maybe (Transformation, Transformation)
forall px.
RenderContext px -> Maybe (Transformation, Transformation)
currentTransformation RenderContext px
ctxt
subRender :: (forall s. DrawContext (ST s) px ()) -> Image px
subRender :: (forall s. DrawContext (ST s) px ()) -> Image px
subRender forall s. DrawContext (ST s) px ()
act =
(forall s. ST s (Image px)) -> Image px
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Image px)) -> Image px)
-> (forall s. ST s (Image px)) -> Image px
forall a b. (a -> b) -> a -> b
$ Int -> Int -> px -> DrawContext (ST s) px () -> ST s (Image px)
forall (m :: * -> *) px.
(PrimMonad m, RenderablePixel px) =>
Int -> Int -> px -> DrawContext m px () -> m (Image px)
runDrawContext Int
width Int
height px
background DrawContext (ST s) px ()
forall s. DrawContext (ST s) px ()
act
textureOf :: RenderContext px -> Texture px
textureOf ctxt :: RenderContext px
ctxt@RenderContext { currentTransformation :: forall px.
RenderContext px -> Maybe (Transformation, Transformation)
currentTransformation = Just (Transformation
_, Transformation
t) } =
Transformation -> Texture px -> Texture px
forall px. Transformation -> Texture px -> Texture px
WithTextureTransform Transformation
t (Texture px -> Texture px) -> Texture px -> Texture px
forall a b. (a -> b) -> a -> b
$ RenderContext px -> Texture px
forall px. RenderContext px -> Texture px
currentTexture RenderContext px
ctxt
textureOf RenderContext px
ctxt = RenderContext px -> Texture px
forall px. RenderContext px -> Texture px
currentTexture RenderContext px
ctxt
geometryOf :: Transformable a => RenderContext px -> a -> a
geometryOf :: RenderContext px -> a -> a
geometryOf RenderContext { currentTransformation :: forall px.
RenderContext px -> Maybe (Transformation, Transformation)
currentTransformation = Just (Transformation
trans, Transformation
_) } =
(Point -> Point) -> a -> a
forall a. Transformable a => (Point -> Point) -> a -> a
transform (Transformation -> Point -> Point
applyTransformation Transformation
trans)
geometryOf RenderContext px
_ = a -> a
forall a. a -> a
id
geometryOfO :: RenderContext px -> DrawOrder px -> DrawOrder px
geometryOfO RenderContext { currentTransformation :: forall px.
RenderContext px -> Maybe (Transformation, Transformation)
currentTransformation = Just (Transformation
trans, Transformation
_) } =
(Point -> Point) -> DrawOrder px -> DrawOrder px
forall px. (Point -> Point) -> DrawOrder px -> DrawOrder px
transformOrder (Transformation -> Point -> Point
applyTransformation Transformation
trans)
geometryOfO RenderContext px
_ = DrawOrder px -> DrawOrder px
forall a. a -> a
id
stupidDefaultTexture :: Texture px
stupidDefaultTexture =
px -> Texture px
forall px. px -> Texture px
SolidTexture (px -> Texture px) -> px -> Texture px
forall a b. (a -> b) -> a -> b
$ (PixelBaseComponent px -> PixelBaseComponent px) -> px -> px
forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap (PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px
forall a b. a -> b -> a
const PixelBaseComponent px
clipBackground) px
background
orderOf :: RenderContext px -> FillMethod -> [[Primitive]] -> DrawOrder px
orderOf RenderContext px
ctxt FillMethod
method [[Primitive]]
primitives = DrawOrder :: forall px.
[[Primitive]]
-> Texture px
-> FillMethod
-> Maybe (Texture (PixelBaseComponent px))
-> (forall s. DrawContext (ST s) px ())
-> DrawOrder px
DrawOrder
{ _orderPrimitives :: [[Primitive]]
_orderPrimitives = [[Primitive]]
primitives
, _orderTexture :: Texture px
_orderTexture = RenderContext px -> Texture px
forall px. RenderContext px -> Texture px
textureOf RenderContext px
ctxt
, _orderFillMethod :: FillMethod
_orderFillMethod = FillMethod
method
, _orderMask :: Maybe (Texture (PixelBaseComponent px))
_orderMask = RenderContext px -> Maybe (Texture (PixelBaseComponent px))
forall px.
RenderContext px -> Maybe (Texture (PixelBaseComponent px))
currentClip RenderContext px
ctxt
, _orderDirect :: forall s. DrawContext (ST s) px ()
_orderDirect = () -> StateT (MutableImage s px) (ST s) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
go :: RenderContext px -> Free (DrawCommand px) () -> [DrawOrder px]
-> [DrawOrder px]
go :: RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
_ (Pure ()) [DrawOrder px]
rest = [DrawOrder px]
rest
go RenderContext px
ctxt (Free (WithGlobalOpacity PixelBaseComponent px
opa Drawing px ()
sub Free (DrawCommand px) ()
next)) [DrawOrder px]
rest =
RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt (DrawCommand px (Free (DrawCommand px) ())
-> Free (DrawCommand px) ()
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free ((Image px -> ImageTransformer px)
-> Drawing px ()
-> Free (DrawCommand px) ()
-> DrawCommand px (Free (DrawCommand px) ())
forall px next.
(Image px -> ImageTransformer px)
-> Drawing px () -> next -> DrawCommand px next
WithImageEffect Image px -> ImageTransformer px
opacifier Drawing px ()
sub Free (DrawCommand px) ()
next)) [DrawOrder px]
rest
where
opacifier :: Image px -> ImageTransformer px
opacifier Image px
_ Int
_ Int
_ px
px = (Int
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px)
-> (PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px)
-> px
-> px
-> px
forall a.
Pixel a =>
(Int
-> PixelBaseComponent a
-> PixelBaseComponent a
-> PixelBaseComponent a)
-> (PixelBaseComponent a
-> PixelBaseComponent a -> PixelBaseComponent a)
-> a
-> a
-> a
mixWithAlpha Int
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
forall p p p. p -> p -> p -> p
ignore PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px
alphaModulate px
px px
px
ignore :: p -> p -> p -> p
ignore p
_ p
_ p
a = p
a
alphaModulate :: PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px
alphaModulate PixelBaseComponent px
_ PixelBaseComponent px
v = PixelBaseComponent px
opa PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px
forall a. Modulable a => a -> a -> a
`modulate` PixelBaseComponent px
v
go RenderContext px
ctxt (Free (WithImageEffect Image px -> ImageTransformer px
effect Drawing px ()
sub Free (DrawCommand px) ()
next)) [DrawOrder px]
rest =
RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
freeContext (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
cached) [DrawOrder px]
after
where
cached :: Drawing px ()
cached = Maybe (Image px -> ImageTransformer px)
-> Int -> Int -> [DrawOrder px] -> Drawing px ()
forall px.
RenderablePixel px =>
Maybe (Image px -> ImageTransformer px)
-> Int -> Int -> [DrawOrder px] -> Drawing px ()
cacheOrders ((Image px -> ImageTransformer px)
-> Maybe (Image px -> ImageTransformer px)
forall a. a -> Maybe a
Just Image px -> ImageTransformer px
effect) Int
forall a. Bounded a => a
maxBound Int
forall a. Bounded a => a
maxBound ([DrawOrder px] -> Drawing px ())
-> [DrawOrder px] -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
sub) []
after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
freeContext :: RenderContext px
freeContext = RenderContext px
ctxt { currentClip :: Maybe (Texture (PixelBaseComponent px))
currentClip = Maybe (Texture (PixelBaseComponent px))
forall a. Maybe a
Nothing, currentTransformation :: Maybe (Transformation, Transformation)
currentTransformation = Maybe (Transformation, Transformation)
forall a. Maybe a
Nothing }
go RenderContext px
ctxt (Free (WithPathOrientation Path
path Float
base Drawing px ()
sub Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = [DrawOrder px]
final where
final :: [DrawOrder px]
final = [DrawOrder px]
orders [DrawOrder px] -> [DrawOrder px] -> [DrawOrder px]
forall a. Semigroup a => a -> a -> a
<> RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
images :: [DrawOrder px]
images = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
sub) []
drawer :: Transformation -> p -> DrawOrder px -> m ()
drawer Transformation
trans p
_ DrawOrder px
order =
([DrawOrder px] -> [DrawOrder px]) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Point -> Point) -> DrawOrder px -> DrawOrder px
forall px. (Point -> Point) -> DrawOrder px -> DrawOrder px
transformOrder (Transformation -> Point -> Point
applyTransformation Transformation
trans) DrawOrder px
order DrawOrder px -> [DrawOrder px] -> [DrawOrder px]
forall a. a -> [a] -> [a]
:)
orders :: [DrawOrder px]
orders = [DrawOrder px] -> [DrawOrder px]
forall a. [a] -> [a]
reverse ([DrawOrder px] -> [DrawOrder px])
-> [DrawOrder px] -> [DrawOrder px]
forall a b. (a -> b) -> a -> b
$ State [DrawOrder px] () -> [DrawOrder px] -> [DrawOrder px]
forall s a. State s a -> s -> s
execState (PathDrawer (StateT [DrawOrder px] Identity) px
-> Float
-> Float
-> Path
-> [DrawOrder px]
-> State [DrawOrder px] ()
forall (m :: * -> *) px.
Monad m =>
PathDrawer m px -> Float -> Float -> Path -> [DrawOrder px] -> m ()
drawOrdersOnPath PathDrawer (StateT [DrawOrder px] Identity) px
forall px (m :: * -> *) p.
MonadState [DrawOrder px] m =>
Transformation -> p -> DrawOrder px -> m ()
drawer Float
0 Float
base Path
path [DrawOrder px]
images) []
go RenderContext px
ctxt (Free (WithTransform Transformation
trans Drawing px ()
sub Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = [DrawOrder px]
final where
trans' :: Transformation
trans'
| Just (Transformation
t, Transformation
_) <- RenderContext px -> Maybe (Transformation, Transformation)
forall px.
RenderContext px -> Maybe (Transformation, Transformation)
currentTransformation RenderContext px
ctxt = Transformation
t Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation
trans
| Bool
otherwise = Transformation
trans
invTrans :: Transformation
invTrans = Transformation -> Maybe Transformation -> Transformation
forall a. a -> Maybe a -> a
fromMaybe Transformation
forall a. Monoid a => a
mempty (Maybe Transformation -> Transformation)
-> Maybe Transformation -> Transformation
forall a b. (a -> b) -> a -> b
$ Transformation -> Maybe Transformation
inverseTransformation Transformation
trans'
after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
subContext :: RenderContext px
subContext =
RenderContext px
ctxt { currentTransformation :: Maybe (Transformation, Transformation)
currentTransformation = (Transformation, Transformation)
-> Maybe (Transformation, Transformation)
forall a. a -> Maybe a
Just (Transformation
trans', Transformation
invTrans) }
final :: [DrawOrder px]
final = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
subContext (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
sub) [DrawOrder px]
after
go RenderContext px
ctxt (Free (CustomRender forall s. DrawContext (ST s) px ()
cust Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = DrawOrder px
order DrawOrder px -> [DrawOrder px] -> [DrawOrder px]
forall a. a -> [a] -> [a]
: [DrawOrder px]
after where
after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
order :: DrawOrder px
order = DrawOrder :: forall px.
[[Primitive]]
-> Texture px
-> FillMethod
-> Maybe (Texture (PixelBaseComponent px))
-> (forall s. DrawContext (ST s) px ())
-> DrawOrder px
DrawOrder
{ _orderPrimitives :: [[Primitive]]
_orderPrimitives = []
, _orderTexture :: Texture px
_orderTexture = RenderContext px -> Texture px
forall px. RenderContext px -> Texture px
textureOf RenderContext px
ctxt
, _orderFillMethod :: FillMethod
_orderFillMethod = FillMethod
FillWinding
, _orderMask :: Maybe (Texture (PixelBaseComponent px))
_orderMask = RenderContext px -> Maybe (Texture (PixelBaseComponent px))
forall px.
RenderContext px -> Maybe (Texture (PixelBaseComponent px))
currentClip RenderContext px
ctxt
, _orderDirect :: forall s. DrawContext (ST s) px ()
_orderDirect = forall s. DrawContext (ST s) px ()
cust
}
go RenderContext px
ctxt (Free (MeshPatchRender PatchInterpolation
i MeshPatch px
mesh Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = DrawOrder px
order DrawOrder px -> [DrawOrder px] -> [DrawOrder px]
forall a. a -> [a] -> [a]
: [DrawOrder px]
after where
after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
rendering :: DrawContext (ST s) px ()
rendering :: DrawContext (ST s) px ()
rendering = case PatchInterpolation
i of
PatchInterpolation
PatchBilinear -> (CoonPatch (ParametricValues px)
-> StateT (MutableImage s px) (ST s) ())
-> [CoonPatch (ParametricValues px)]
-> StateT (MutableImage s px) (ST s) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CoonPatch (ParametricValues px)
-> StateT (MutableImage s px) (ST s) ()
forall (m :: * -> *) px src.
(PrimMonad m, ModulablePixel px, BiSampleable src px) =>
CoonPatch src -> DrawContext m px ()
rasterizeCoonPatch ([CoonPatch (ParametricValues px)]
-> StateT (MutableImage s px) (ST s) ())
-> [CoonPatch (ParametricValues px)]
-> StateT (MutableImage s px) (ST s) ()
forall a b. (a -> b) -> a -> b
$ MeshPatch px -> [CoonPatch (ParametricValues px)]
forall px. MeshPatch px -> [CoonPatch (ParametricValues px)]
coonPatchesOf (MeshPatch px -> [CoonPatch (ParametricValues px)])
-> MeshPatch px -> [CoonPatch (ParametricValues px)]
forall a b. (a -> b) -> a -> b
$ RenderContext px -> MeshPatch px -> MeshPatch px
forall a. Transformable a => RenderContext px -> a -> a
geometryOf RenderContext px
ctxt MeshPatch px
opaqueMesh
PatchInterpolation
PatchBicubic ->
(CoonPatch (CubicCoefficient px)
-> StateT (MutableImage s px) (ST s) ())
-> [CoonPatch (CubicCoefficient px)]
-> StateT (MutableImage s px) (ST s) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CoonPatch (CubicCoefficient px)
-> StateT (MutableImage s px) (ST s) ()
forall (m :: * -> *) px src.
(PrimMonad m, ModulablePixel px, BiSampleable src px) =>
CoonPatch src -> DrawContext m px ()
rasterizeCoonPatch
([CoonPatch (CubicCoefficient px)]
-> StateT (MutableImage s px) (ST s) ())
-> (MeshPatch (Derivative px) -> [CoonPatch (CubicCoefficient px)])
-> MeshPatch (Derivative px)
-> StateT (MutableImage s px) (ST s) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MeshPatch (Derivative px) -> [CoonPatch (CubicCoefficient px)]
forall px.
InterpolablePixel px =>
MeshPatch (Derivative px) -> [CoonPatch (CubicCoefficient px)]
cubicCoonPatchesOf
(MeshPatch (Derivative px) -> StateT (MutableImage s px) (ST s) ())
-> MeshPatch (Derivative px)
-> StateT (MutableImage s px) (ST s) ()
forall a b. (a -> b) -> a -> b
$ MeshPatch px -> MeshPatch (Derivative px)
forall px.
InterpolablePixel px =>
MeshPatch px -> MeshPatch (Derivative px)
calculateMeshColorDerivative (MeshPatch px -> MeshPatch (Derivative px))
-> MeshPatch px -> MeshPatch (Derivative px)
forall a b. (a -> b) -> a -> b
$ RenderContext px -> MeshPatch px -> MeshPatch px
forall a. Transformable a => RenderContext px -> a -> a
geometryOf RenderContext px
ctxt MeshPatch px
opaqueMesh
hasTransparency :: Bool
hasTransparency =
(px -> Bool) -> Vector px -> Bool
forall a. (a -> Bool) -> Vector a -> Bool
V.any ((PixelBaseComponent px -> PixelBaseComponent px -> Bool
forall a. Eq a => a -> a -> Bool
/= PixelBaseComponent px
forall a. Modulable a => a
fullValue) (PixelBaseComponent px -> Bool)
-> (px -> PixelBaseComponent px) -> px -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. px -> PixelBaseComponent px
forall a. Pixel a => a -> PixelBaseComponent a
pixelOpacity) (Vector px -> Bool) -> Vector px -> Bool
forall a b. (a -> b) -> a -> b
$ MeshPatch px -> Vector px
forall px. MeshPatch px -> Vector px
_meshColors MeshPatch px
mesh
opacifier :: a -> a
opacifier a
px = (Int
-> PixelBaseComponent a
-> PixelBaseComponent a
-> PixelBaseComponent a)
-> (PixelBaseComponent a
-> PixelBaseComponent a -> PixelBaseComponent a)
-> a
-> a
-> a
forall a.
Pixel a =>
(Int
-> PixelBaseComponent a
-> PixelBaseComponent a
-> PixelBaseComponent a)
-> (PixelBaseComponent a
-> PixelBaseComponent a -> PixelBaseComponent a)
-> a
-> a
-> a
mixWithAlpha (\Int
_ PixelBaseComponent a
_ PixelBaseComponent a
a -> PixelBaseComponent a
a) (\PixelBaseComponent a
_ PixelBaseComponent a
_ -> PixelBaseComponent a
forall a. Modulable a => a
fullValue) a
px a
px
opaqueMesh :: MeshPatch px
opaqueMesh = px -> px
forall a. (Pixel a, Modulable (PixelBaseComponent a)) => a -> a
opacifier (px -> px) -> MeshPatch px -> MeshPatch px
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MeshPatch px
mesh
transparencyMesh :: MeshPatch (PixelBaseComponent px)
transparencyMesh = px -> PixelBaseComponent px
forall a. Pixel a => a -> PixelBaseComponent a
pixelOpacity (px -> PixelBaseComponent px)
-> MeshPatch px -> MeshPatch (PixelBaseComponent px)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MeshPatch px
mesh
clipPath :: Maybe (Texture (PixelBaseComponent px))
clipPath
| Bool -> Bool
not Bool
hasTransparency = RenderContext px -> Maybe (Texture (PixelBaseComponent px))
forall px.
RenderContext px -> Maybe (Texture (PixelBaseComponent px))
currentClip RenderContext px
ctxt
| Bool
otherwise =
let newMask :: Image (PixelBaseComponent (PixelBaseComponent px))
newMask :: Image (PixelBaseComponent (PixelBaseComponent px))
newMask = RenderContext px
-> Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px)
clipRender RenderContext px
ctxt (Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px))
-> Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px)
forall a b. (a -> b) -> a -> b
$ PatchInterpolation
-> MeshPatch (PixelBaseComponent px)
-> Drawing (PixelBaseComponent px) ()
forall px. PatchInterpolation -> MeshPatch px -> Drawing px ()
renderMeshPatch PatchInterpolation
i MeshPatch (PixelBaseComponent px)
transparencyMesh in
case RenderContext px -> Maybe (Texture (PixelBaseComponent px))
forall px.
RenderContext px -> Maybe (Texture (PixelBaseComponent px))
currentClip RenderContext px
ctxt of
Maybe (Texture (PixelBaseComponent px))
Nothing -> Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px))
forall a. a -> Maybe a
Just (Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px)))
-> Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px))
forall a b. (a -> b) -> a -> b
$ Image (PixelBaseComponent px) -> Texture (PixelBaseComponent px)
forall px. Image px -> Texture px
RawTexture Image (PixelBaseComponent px)
Image (PixelBaseComponent (PixelBaseComponent px))
newMask
Just Texture (PixelBaseComponent px)
v -> Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px))
forall a. a -> Maybe a
Just (Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px)))
-> Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px))
forall a b. (a -> b) -> a -> b
$ Texture (PixelBaseComponent px)
-> Texture (PixelBaseComponent (PixelBaseComponent px))
-> Texture (PixelBaseComponent px)
forall px.
Texture px -> Texture (PixelBaseComponent px) -> Texture px
ModulateTexture Texture (PixelBaseComponent px)
v (Image (PixelBaseComponent px) -> Texture (PixelBaseComponent px)
forall px. Image px -> Texture px
RawTexture Image (PixelBaseComponent px)
Image (PixelBaseComponent (PixelBaseComponent px))
newMask)
order :: DrawOrder px
order = case Maybe (Texture (PixelBaseComponent px))
clipPath of
Maybe (Texture (PixelBaseComponent px))
Nothing -> DrawOrder :: forall px.
[[Primitive]]
-> Texture px
-> FillMethod
-> Maybe (Texture (PixelBaseComponent px))
-> (forall s. DrawContext (ST s) px ())
-> DrawOrder px
DrawOrder
{ _orderPrimitives :: [[Primitive]]
_orderPrimitives = []
, _orderTexture :: Texture px
_orderTexture = RenderContext px -> Texture px
forall px. RenderContext px -> Texture px
textureOf RenderContext px
ctxt
, _orderFillMethod :: FillMethod
_orderFillMethod = FillMethod
FillWinding
, _orderMask :: Maybe (Texture (PixelBaseComponent px))
_orderMask = Maybe (Texture (PixelBaseComponent px))
clipPath
, _orderDirect :: forall s. DrawContext (ST s) px ()
_orderDirect = forall s. DrawContext (ST s) px ()
rendering
}
Just Texture (PixelBaseComponent px)
c -> DrawOrder :: forall px.
[[Primitive]]
-> Texture px
-> FillMethod
-> Maybe (Texture (PixelBaseComponent px))
-> (forall s. DrawContext (ST s) px ())
-> DrawOrder px
DrawOrder
{ _orderPrimitives :: [[Primitive]]
_orderPrimitives = [RenderContext px -> [Primitive] -> [Primitive]
forall a. Transformable a => RenderContext px -> a -> a
geometryOf RenderContext px
ctxt ([Primitive] -> [Primitive]) -> [Primitive] -> [Primitive]
forall a b. (a -> b) -> a -> b
$ Point -> Float -> Float -> [Primitive]
rectangle (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
0 Float
0) (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)]
, _orderTexture :: Texture px
_orderTexture = Texture px -> Texture (PixelBaseComponent px) -> Texture px
forall px.
Texture px -> Texture (PixelBaseComponent px) -> Texture px
AlphaModulateTexture (Image px -> Texture px
forall px. Image px -> Texture px
RawTexture (Image px -> Texture px) -> Image px -> Texture px
forall a b. (a -> b) -> a -> b
$ (forall s. DrawContext (ST s) px ()) -> Image px
subRender forall s. DrawContext (ST s) px ()
rendering) Texture (PixelBaseComponent px)
c
, _orderFillMethod :: FillMethod
_orderFillMethod = FillMethod
FillWinding
, _orderMask :: Maybe (Texture (PixelBaseComponent px))
_orderMask = Maybe (Texture (PixelBaseComponent px))
forall a. Maybe a
Nothing
, _orderDirect :: forall s. DrawContext (ST s) px ()
_orderDirect = () -> StateT (MutableImage s px) (ST s) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
go RenderContext px
ctxt (Free (Fill FillMethod
method [Primitive]
prims Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = DrawOrder px
order DrawOrder px -> [DrawOrder px] -> [DrawOrder px]
forall a. a -> [a] -> [a]
: [DrawOrder px]
after where
after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
order :: DrawOrder px
order = RenderContext px -> FillMethod -> [[Primitive]] -> DrawOrder px
forall px.
RenderContext px -> FillMethod -> [[Primitive]] -> DrawOrder px
orderOf RenderContext px
ctxt FillMethod
method [RenderContext px -> [Primitive] -> [Primitive]
forall a. Transformable a => RenderContext px -> a -> a
geometryOf RenderContext px
ctxt [Primitive]
prims [Primitive] -> (Primitive -> [Primitive]) -> [Primitive]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Container Primitive -> [Primitive]
forall a. Container a -> [a]
listOfContainer (Container Primitive -> [Primitive])
-> (Primitive -> Container Primitive) -> Primitive -> [Primitive]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Primitive -> Container Primitive
sanitizeFilling]
go RenderContext px
ctxt (Free (Stroke Float
w Join
j (Cap, Cap)
cap [Primitive]
prims Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = DrawOrder px
order DrawOrder px -> [DrawOrder px] -> [DrawOrder px]
forall a. a -> [a] -> [a]
: [DrawOrder px]
after where
after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
order :: DrawOrder px
order = RenderContext px -> FillMethod -> [[Primitive]] -> DrawOrder px
forall px.
RenderContext px -> FillMethod -> [[Primitive]] -> DrawOrder px
orderOf RenderContext px
ctxt FillMethod
FillWinding [RenderContext px -> [Primitive] -> [Primitive]
forall a. Transformable a => RenderContext px -> a -> a
geometryOf RenderContext px
ctxt [Primitive]
prim']
prim' :: [Primitive]
prim' = Container Primitive -> [Primitive]
forall a. Container a -> [a]
listOfContainer (Container Primitive -> [Primitive])
-> Container Primitive -> [Primitive]
forall a b. (a -> b) -> a -> b
$ Float -> Join -> (Cap, Cap) -> [Primitive] -> Container Primitive
forall geom.
Geometry geom =>
Float -> Join -> (Cap, Cap) -> geom -> Container Primitive
strokize Float
w Join
j (Cap, Cap)
cap [Primitive]
prims
go RenderContext px
ctxt (Free (SetTexture Texture px
tx Drawing px ()
sub Free (DrawCommand px) ()
next)) [DrawOrder px]
rest =
RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go (RenderContext px
ctxt { currentTexture :: Texture px
currentTexture = Texture px
tx }) (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
sub) ([DrawOrder px] -> [DrawOrder px])
-> [DrawOrder px] -> [DrawOrder px]
forall a b. (a -> b) -> a -> b
$
RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
go RenderContext px
ctxt (Free (DashedStroke Float
o DashPattern
d Float
w Join
j (Cap, Cap)
cap [Primitive]
prims Free (DrawCommand px) ()
next)) [DrawOrder px]
rest =
([Primitive] -> [DrawOrder px] -> [DrawOrder px])
-> [DrawOrder px] -> [[Primitive]] -> [DrawOrder px]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Primitive] -> [DrawOrder px] -> [DrawOrder px]
recurse [DrawOrder px]
after ([[Primitive]] -> [DrawOrder px])
-> [[Primitive]] -> [DrawOrder px]
forall a b. (a -> b) -> a -> b
$ Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> [Primitive]
-> [[Primitive]]
forall geom.
Geometry geom =>
Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> [[Primitive]]
dashedStrokize Float
o DashPattern
d Float
w Join
j (Cap, Cap)
cap [Primitive]
prims
where
after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
recurse :: [Primitive] -> [DrawOrder px] -> [DrawOrder px]
recurse [Primitive]
sub =
RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt (DrawCommand px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Free (DrawCommand px) ())
-> DrawCommand px () -> Free (DrawCommand px) ()
forall a b. (a -> b) -> a -> b
$ FillMethod -> [Primitive] -> () -> DrawCommand px ()
forall px next.
FillMethod -> [Primitive] -> next -> DrawCommand px next
Fill FillMethod
FillWinding [Primitive]
sub ())
go RenderContext px
ctxt (Free (TextFill Point
p [TextRange px]
descriptions Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = [DrawOrder px]
calls [DrawOrder px] -> [DrawOrder px] -> [DrawOrder px]
forall a. Semigroup a => a -> a -> a
<> RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest where
calls :: [DrawOrder px]
calls =
RenderContext px -> DrawOrder px -> DrawOrder px
forall px px. RenderContext px -> DrawOrder px -> DrawOrder px
geometryOfO RenderContext px
ctxt (DrawOrder px -> DrawOrder px) -> [DrawOrder px] -> [DrawOrder px]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Texture px -> Point -> [TextRange px] -> [DrawOrder px]
forall px.
Int -> Texture px -> Point -> [TextRange px] -> [DrawOrder px]
textToDrawOrders Int
dpi (RenderContext px -> Texture px
forall px. RenderContext px -> Texture px
currentTexture RenderContext px
ctxt) Point
p [TextRange px]
descriptions
go RenderContext px
ctxt (Free (WithCliping forall innerPixel. Drawing innerPixel ()
clipPath Drawing px ()
path Free (DrawCommand px) ()
next)) [DrawOrder px]
rest =
RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go (RenderContext px
ctxt { currentClip :: Maybe (Texture (PixelBaseComponent px))
currentClip = Maybe (Texture (PixelBaseComponent px))
newModuler }) (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
path) ([DrawOrder px] -> [DrawOrder px])
-> [DrawOrder px] -> [DrawOrder px]
forall a b. (a -> b) -> a -> b
$
RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
where
modulationTexture :: Texture (PixelBaseComponent px)
modulationTexture :: Texture (PixelBaseComponent px)
modulationTexture = Image (PixelBaseComponent px) -> Texture (PixelBaseComponent px)
forall px. Image px -> Texture px
RawTexture (Image (PixelBaseComponent px) -> Texture (PixelBaseComponent px))
-> Image (PixelBaseComponent px) -> Texture (PixelBaseComponent px)
forall a b. (a -> b) -> a -> b
$ RenderContext px
-> Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px)
clipRender RenderContext px
ctxt Drawing (PixelBaseComponent px) ()
forall innerPixel. Drawing innerPixel ()
clipPath
newModuler :: Maybe (Texture (PixelBaseComponent px))
newModuler = Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px))
forall a. a -> Maybe a
Just (Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px)))
-> (Maybe (Texture (PixelBaseComponent px))
-> Texture (PixelBaseComponent px))
-> Maybe (Texture (PixelBaseComponent px))
-> Maybe (Texture (PixelBaseComponent px))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Texture (PixelBaseComponent px))
-> Texture (PixelBaseComponent px)
subModuler (Maybe (Texture (PixelBaseComponent px))
-> Maybe (Texture (PixelBaseComponent px)))
-> Maybe (Texture (PixelBaseComponent px))
-> Maybe (Texture (PixelBaseComponent px))
forall a b. (a -> b) -> a -> b
$ RenderContext px -> Maybe (Texture (PixelBaseComponent px))
forall px.
RenderContext px -> Maybe (Texture (PixelBaseComponent px))
currentClip RenderContext px
ctxt
subModuler :: Maybe (Texture (PixelBaseComponent px))
-> Texture (PixelBaseComponent px)
subModuler Maybe (Texture (PixelBaseComponent px))
Nothing = Texture (PixelBaseComponent px)
modulationTexture
subModuler (Just Texture (PixelBaseComponent px)
v) =
Texture (PixelBaseComponent px)
-> Texture (PixelBaseComponent (PixelBaseComponent px))
-> Texture (PixelBaseComponent px)
forall px.
Texture px -> Texture (PixelBaseComponent px) -> Texture px
ModulateTexture Texture (PixelBaseComponent px)
v Texture (PixelBaseComponent px)
Texture (PixelBaseComponent (PixelBaseComponent px))
modulationTexture
dashedStroke
:: Geometry geom
=> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
dashedStroke :: DashPattern -> Float -> Join -> (Cap, Cap) -> geom -> Drawing px ()
dashedStroke = Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
forall geom px.
Geometry geom =>
Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
dashedStrokeWithOffset Float
0.0
dashedStrokeWithOffset
:: Geometry geom
=> Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
dashedStrokeWithOffset :: Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
dashedStrokeWithOffset Float
_ [] Float
width Join
join (Cap, Cap)
caping geom
prims =
Float -> Join -> (Cap, Cap) -> geom -> Drawing px ()
forall geom px.
Geometry geom =>
Float -> Join -> (Cap, Cap) -> geom -> Drawing px ()
stroke Float
width Join
join (Cap, Cap)
caping geom
prims
dashedStrokeWithOffset Float
offset DashPattern
dashing Float
width Join
join (Cap, Cap)
caping geom
prims =
DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> [Primitive]
-> ()
-> DrawCommand px ()
forall px next.
Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> [Primitive]
-> next
-> DrawCommand px next
DashedStroke Float
offset DashPattern
dashing Float
width Join
join (Cap, Cap)
caping (geom -> [Primitive]
forall a. Geometry a => a -> [Primitive]
toPrimitives geom
prims) ()
polyline :: [Point] -> [Primitive]
polyline :: [Point] -> [Primitive]
polyline = (Line -> Primitive) -> [Line] -> [Primitive]
forall a b. (a -> b) -> [a] -> [b]
map Line -> Primitive
LinePrim ([Line] -> [Primitive])
-> ([Point] -> [Line]) -> [Point] -> [Primitive]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> [Line]
lineFromPath
polygon :: [Point] -> [Primitive]
polygon :: [Point] -> [Primitive]
polygon [] = []
polygon [Point
_] = []
polygon [Point
_,Point
_] = []
polygon lst :: [Point]
lst@(Point
p:[Point]
_) = [Point] -> [Primitive]
polyline ([Point] -> [Primitive]) -> [Point] -> [Primitive]
forall a b. (a -> b) -> a -> b
$ [Point]
lst [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point
p]
drawImage :: Image px
-> StrokeWidth
-> Point
-> Drawing px ()
drawImage :: Image px -> Float -> Point -> Drawing px ()
drawImage img :: Image px
img@Image { imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h } Float
s Point
p =
Image px -> Float -> Point -> Float -> Float -> Drawing px ()
forall px.
Image px -> Float -> Point -> Float -> Float -> Drawing px ()
drawImageAtSize Image px
img Float
s Point
p (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
drawImageAtSize :: Image px
-> StrokeWidth
-> Point
-> Float
-> Float
-> Drawing px ()
drawImageAtSize :: Image px -> Float -> Point -> Float -> Float -> Drawing px ()
drawImageAtSize img :: Image px
img@Image { imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h } Float
borderSize Point
ip
Float
reqWidth Float
reqHeight
| Float
borderSize Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 =
Transformation -> Drawing px () -> Drawing px ()
forall px. Transformation -> Drawing px () -> Drawing px ()
withTransformation (Point -> Transformation
translate Point
p Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Float -> Float -> Transformation
scale Float
scaleX Float
scaleY) (Drawing px () -> Drawing px ())
-> (Drawing px () -> Drawing px ())
-> Drawing px ()
-> Drawing px ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Texture px -> Drawing px () -> Drawing px ()
forall px. Texture px -> Drawing px () -> Drawing px ()
withTexture (Image px -> Texture px
forall px. Image px -> Texture px
SampledTexture Image px
img) (Drawing px () -> Drawing px ()) -> Drawing px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ [Primitive] -> Drawing px ()
forall geom px. Geometry geom => geom -> Drawing px ()
fill [Primitive]
rect
| Bool
otherwise = do
Transformation -> Drawing px () -> Drawing px ()
forall px. Transformation -> Drawing px () -> Drawing px ()
withTransformation (Point -> Transformation
translate Point
p Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Float -> Float -> Transformation
scale Float
scaleX Float
scaleY) (Drawing px () -> Drawing px ()) -> Drawing px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$
Texture px -> Drawing px () -> Drawing px ()
forall px. Texture px -> Drawing px () -> Drawing px ()
withTexture (Image px -> Texture px
forall px. Image px -> Texture px
SampledTexture Image px
img) (Drawing px () -> Drawing px ()) -> Drawing px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ [Primitive] -> Drawing px ()
forall geom px. Geometry geom => geom -> Drawing px ()
fill [Primitive]
rect
Float -> Join -> (Cap, Cap) -> [Primitive] -> Drawing px ()
forall geom px.
Geometry geom =>
Float -> Join -> (Cap, Cap) -> geom -> Drawing px ()
stroke (Float
borderSize Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float -> Join
JoinMiter Float
0)
(Float -> Cap
CapStraight Float
0, Float -> Cap
CapStraight Float
0) [Primitive]
rect'
where
p :: Point
p = Point
ip Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
0.5 Float
0.5
rect :: [Primitive]
rect = Point -> Float -> Float -> [Primitive]
rectangle (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
0 Float
0) Float
rw Float
rh
rect' :: [Primitive]
rect' = Point -> Float -> Float -> [Primitive]
rectangle Point
p Float
reqWidth Float
reqHeight
(Float
rw, Float
rh) = (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w, Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
scaleX :: Float
scaleX | Float
reqWidth Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 = Float
1
| Bool
otherwise = Float
reqWidth Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
rw
scaleY :: Float
scaleY | Float
reqHeight Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 = Float
1
| Bool
otherwise = Float
reqHeight Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
rh
line :: Point -> Point -> [Primitive]
line :: Point -> Point -> [Primitive]
line Point
p1 Point
p2 = [Line -> Primitive
LinePrim (Line -> Primitive) -> Line -> Primitive
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Line
Line Point
p1 Point
p2]