module Graphics.Rasterific
(
fill
, fillWithMethod
, withTexture
, withClipping
, withTransformation
, stroke
, dashedStroke
, dashedStrokeWithOffset
, printTextAt
, renderDrawing
, pathToPrimitives
, Texture
, Drawing
, Modulable
, V2( .. )
, Point
, Vector
, CubicBezier( .. )
, Line( .. )
, Bezier( .. )
, Primitive( .. )
, Path( .. )
, PathCommand( .. )
, Transformable( .. )
, PointFoldable( .. )
, line
, rectangle
, roundedRectangle
, circle
, ellipse
, polyline
, polygon
, drawImageAtSize
, drawImage
, clip
, bezierFromPath
, lineFromPath
, cubicBezierFromPath
, Join( .. )
, Cap( .. )
, SamplerRepeat( .. )
, FillMethod( .. )
, DashPattern
, dumpDrawing
) where
import Control.Applicative( (<$>) )
import Control.Monad( forM_ )
import Control.Monad.Free( Free( .. ), liftF )
import Control.Monad.ST( ST, runST )
import Control.Monad.State( StateT, execStateT, get, lift )
import Data.Monoid( Monoid( .. ), (<>) )
import Codec.Picture.Types( Image( .. )
, Pixel( .. )
, Pixel8
, PixelRGBA8
, MutableImage( .. )
, createMutableImage
, unsafeFreezeImage )
import qualified Data.Vector.Unboxed as VU
import Linear( V2( .. ), (^+^), (^*) )
import Graphics.Rasterific.Compositor
import Graphics.Rasterific.Rasterize
import Graphics.Rasterific.Texture
import Graphics.Rasterific.Types
import Graphics.Rasterific.Line
import Graphics.Rasterific.QuadraticBezier
import Graphics.Rasterific.CubicBezier
import Graphics.Rasterific.Stroke
import Graphics.Rasterific.Transformations
import Graphics.Text.TrueType( Font, PointSize, getStringCurveAtPoint )
type DrawContext s px a =
StateT (MutableImage s px) (ST s) a
type Drawing px = Free (DrawCommand px)
data DrawCommand px next
= Fill FillMethod [Primitive] next
| Stroke Float Join (Cap, Cap) [Primitive] next
| DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next
| TextFill Font PointSize Point String next
| SetTexture (Texture px)
(Drawing px ()) next
| WithCliping (forall innerPixel. Drawing innerPixel ())
(Drawing px ()) next
| WithTransform Transformation (Drawing px ()) next
dumpDrawing :: (Show px) => Drawing px () -> String
dumpDrawing (Pure ()) = "return ()"
dumpDrawing (Free (Fill _ prims next)) =
"fill " ++ show prims ++ " >>=\n" ++ dumpDrawing next
dumpDrawing (Free (TextFill _ _ _ text next)) =
"-- Text : " ++ text ++ "\n" ++ dumpDrawing next
dumpDrawing (Free (SetTexture _tx drawing next)) =
"withTexture ({- texture -}) (" ++
dumpDrawing drawing ++ ") >>=\n" ++ dumpDrawing next
dumpDrawing (Free (DashedStroke o pat w j cap prims next)) =
"dashedStrokeWithOffset "
++ show o ++ " "
++ show pat ++ " "
++ show w ++ " ("
++ show j ++ ") "
++ show cap ++ " "
++ show prims ++ " >>=\n" ++ dumpDrawing next
dumpDrawing (Free (Stroke w j cap prims next)) =
"stroke " ++ show w ++ " ("
++ show j ++ ") "
++ show cap ++ " "
++ show prims ++ " >>=\n" ++ dumpDrawing next
dumpDrawing (Free (WithTransform trans sub next)) =
"withTransform (" ++ show trans ++ ") ("
++ dumpDrawing sub ++ ") >>=\n "
++ dumpDrawing next
dumpDrawing (Free (WithCliping clipping draw next)) =
"withClipping (" ++ dumpDrawing (withTexture clipTexture clipping)
++ ")\n" ++
" (" ++ dumpDrawing draw++ ")\n >>= " ++
dumpDrawing next
where clipTexture = uniformTexture (0xFF :: Pixel8)
instance Functor (DrawCommand px) where
fmap f (TextFill font size pos str next) =
TextFill font size pos str $ f next
fmap f (Fill method prims next) = Fill method prims $ f next
fmap f (SetTexture t sub next) = SetTexture t sub $ f next
fmap f (WithCliping sub com next) =
WithCliping sub com $ f next
fmap f (Stroke w j caps prims next) =
Stroke w j caps prims $ f next
fmap f (DashedStroke st pat w j caps prims next) =
DashedStroke st pat w j caps prims $ f next
fmap f (WithTransform trans draw next) =
WithTransform trans draw $ f next
instance Monoid (Drawing px ()) where
mempty = return ()
mappend (Pure ()) b = b
mappend a (Pure ()) = a
mappend a b = a >> b
withTexture :: Texture px -> Drawing px () -> Drawing px ()
withTexture texture subActions =
liftF $ SetTexture texture subActions ()
withTransformation :: Transformation -> Drawing px () -> Drawing px ()
withTransformation trans sub =
liftF $ WithTransform trans sub ()
fill :: [Primitive] -> Drawing px ()
fill prims = liftF $ Fill FillWinding prims ()
fillWithMethod :: FillMethod -> [Primitive] -> Drawing px ()
fillWithMethod method prims =
liftF $ Fill method prims ()
withClipping
:: (forall innerPixel. Drawing innerPixel ())
-> Drawing px ()
-> Drawing px ()
withClipping clipPath drawing =
liftF $ WithCliping clipPath drawing ()
stroke :: Float
-> Join
-> (Cap, Cap)
-> [Primitive]
-> Drawing px ()
stroke width join caping prims =
liftF $ Stroke width join caping prims ()
printTextAt :: Font
-> Int
-> Point
-> String
-> Drawing px ()
printTextAt font pointSize point string =
liftF $ TextFill font pointSize point string ()
data RenderContext px = RenderContext
{ currentClip :: Maybe (Texture (PixelBaseComponent px))
, currentTexture :: Texture px
, currentTransformation :: Maybe (Transformation, Transformation)
}
renderDrawing
:: forall px
. ( Pixel px
, Pixel (PixelBaseComponent px)
, Modulable (PixelBaseComponent px)
, PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px)
)
=> Int
-> Int
-> px
-> Drawing px ()
-> Image px
renderDrawing width height background drawing = runST $
createMutableImage width height background
>>= execStateT (go initialContext drawing)
>>= unsafeFreezeImage
where
initialContext = RenderContext Nothing stupidDefaultTexture Nothing
clipBackground = emptyValue :: PixelBaseComponent px
clipForeground = fullValue :: PixelBaseComponent px
stupidDefaultTexture =
uniformTexture $ colorMap (const clipBackground) background
clipRender =
renderDrawing width height clipBackground
. withTexture (uniformTexture clipForeground)
textureOf ctxt@RenderContext { currentTransformation = Just (_, t) } =
transformTexture t $ currentTexture ctxt
textureOf ctxt = currentTexture ctxt
geometryOf RenderContext { currentTransformation = Just (trans, _) } =
transform (applyTransformation trans)
geometryOf _ = id
go :: RenderContext px
-> Drawing px ()
-> DrawContext s px ()
go _ (Pure ()) = return ()
go ctxt (Free (WithTransform trans sub next)) = do
let trans'
| Just (t, _) <- currentTransformation ctxt = t <> trans
| otherwise = trans
go ctxt { currentTransformation =
Just (trans', inverseTransformation trans') } sub
go ctxt next
go ctxt@RenderContext { currentClip = Nothing }
(Free (Fill method prims next)) = do
fillWithTexture method (textureOf ctxt) $ geometryOf ctxt prims
go ctxt next
go ctxt@RenderContext { currentClip = Just moduler }
(Free (Fill method prims next)) = do
fillWithTextureAndMask method (currentTexture ctxt)
moduler $ geometryOf ctxt prims
go ctxt next
go ctxt (Free (Stroke w j cap prims next)) =
go ctxt . Free $ Fill FillWinding prim' next
where prim' = strokize w j cap prims
go ctxt (Free (SetTexture tx sub next)) = do
go (ctxt { currentTexture = tx }) sub
go ctxt next
go ctxt (Free (DashedStroke o d w j cap prims next)) = do
let recurse sub =
go ctxt . liftF $ Fill FillWinding sub ()
mapM_ recurse $ dashedStrokize o d w j cap prims
go ctxt next
go ctxt (Free (TextFill font size (V2 x y) str next)) = do
forM_ drawCalls (go ctxt)
go ctxt next
where
drawCalls =
beziersOfChar <$> getStringCurveAtPoint 90 (x, y)
[(font, size, str)]
beziersOfChar curves = liftF $ Fill FillWinding bezierCurves ()
where
bezierCurves = concat
[map BezierPrim . bezierFromPath . map (uncurry V2)
$ VU.toList c | c <- curves]
go ctxt (Free (WithCliping clipPath path next)) = do
go (ctxt { currentClip = newModuler }) path
go ctxt next
where
modulationTexture :: Texture (PixelBaseComponent px)
modulationTexture = imageTexture $ clipRender clipPath
newModuler = Just . subModuler $ currentClip ctxt
subModuler Nothing = modulationTexture
subModuler (Just v) =
modulateTexture v modulationTexture
dashedStroke
:: DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> [Primitive]
-> Drawing px ()
dashedStroke = dashedStrokeWithOffset 0.0
dashedStrokeWithOffset
:: Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> [Primitive]
-> 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 prims ()
clip :: Point
-> Point
-> Primitive
-> [Primitive]
clip mini maxi (LinePrim l) = clipLine mini maxi l
clip mini maxi (BezierPrim b) = clipBezier mini maxi b
clip mini maxi (CubicBezierPrim c) = clipCubicBezier mini maxi c
fillWithTexture :: (Pixel px, Modulable (PixelBaseComponent px))
=> FillMethod
-> Texture px
-> [Primitive]
-> DrawContext s px ()
fillWithTexture fillMethod texture els = do
img@(MutableImage width height _) <- get
let mini = V2 0 0
maxi = V2 (fromIntegral width) (fromIntegral height)
spans = rasterize fillMethod $ els >>= clip mini maxi
lift $ mapM_ (composeCoverageSpan texture img) spans
fillWithTextureAndMask
:: ( Pixel px
, Pixel (PixelBaseComponent px)
, Modulable (PixelBaseComponent px))
=> FillMethod
-> Texture px
-> Texture (PixelBaseComponent px)
-> [Primitive]
-> DrawContext s 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 $ els >>= clip mini maxi
lift $ mapM_ (composeCoverageSpanWithMask texture mask img) spans
composeCoverageSpan :: forall s px .
( Pixel px, Modulable (PixelBaseComponent px) )
=> Texture px
-> MutableImage s px
-> CoverageSpan
-> ST s ()
composeCoverageSpan texture img coverage
| initialCov == 0 || initialX < 0 || y < 0 || imgWidth < initialX || imgHeight < y = return ()
| otherwise = go 0 initialX initIndex
where compCount = componentCount (undefined :: px)
maxi = _coverageLength coverage
imgData = mutableImageData img
y = floor $ _coverageY coverage
initialX = floor $ _coverageX coverage
imgWidth = mutableImageWidth img
imgHeight = mutableImageHeight img
initIndex = (initialX + y * imgWidth) * compCount
(initialCov, _) =
clampCoverage $ _coverageVal coverage
shader = texture SamplerPad
go count _ _ | count >= maxi = return ()
go count x idx = do
oldPixel <- unsafeReadPixel imgData idx
let px = shader (fromIntegral x) (fromIntegral y)
opacity = pixelOpacity px
(cov, icov) = coverageModulate initialCov opacity
unsafeWritePixel imgData idx
$ compositionAlpha cov icov oldPixel px
go (count + 1) (x + 1) $ idx + compCount
composeCoverageSpanWithMask
:: forall s px
. ( Pixel px
, Pixel (PixelBaseComponent px)
, Modulable (PixelBaseComponent px) )
=> Texture px
-> Texture (PixelBaseComponent px)
-> MutableImage s px
-> CoverageSpan
-> ST s ()
composeCoverageSpanWithMask texture mask img coverage
| initialCov == 0 || initialX < 0 || y < 0 || imgWidth < initialX || imgHeight < y = return ()
| otherwise = go 0 initialX initIndex
where compCount = componentCount (undefined :: px)
maxi = _coverageLength coverage
imgData = mutableImageData img
y = floor $ _coverageY coverage
initialX = floor $ _coverageX coverage
imgWidth = mutableImageWidth img
imgHeight = mutableImageHeight img
initIndex = (initialX + y * imgWidth) * compCount
(initialCov, _) =
clampCoverage $ _coverageVal coverage
maskShader = mask SamplerPad
shader = texture SamplerPad
go count _ _ | count >= maxi = return ()
go count x idx = do
oldPixel <- unsafeReadPixel imgData idx
let fx = fromIntegral x
fy = fromIntegral y
maskValue = maskShader fx fy
px = shader fx fy
(coeffMasked, _) = coverageModulate initialCov maskValue
(cov, icov) = coverageModulate coeffMasked $ pixelOpacity px
unsafeWritePixel imgData idx
$ compositionAlpha cov icov oldPixel px
go (count + 1) (x + 1) $ idx + compCount
circle :: Point
-> Float
-> [Primitive]
circle center radius =
CubicBezierPrim . transform mv <$> cubicBezierCircle
where
mv p = (p ^* radius) ^+^ center
ellipse :: Point -> Float -> Float -> [Primitive]
ellipse center rx ry =
CubicBezierPrim . transform mv <$> cubicBezierCircle
where
mv (V2 x y) = V2 (x * rx) (y * ry) ^+^ center
polyline :: [Point] -> [Primitive]
polyline = map LinePrim . lineFromPath
polygon :: [Point] -> [Primitive]
polygon [] = []
polygon [_] = []
polygon [_,_] = []
polygon lst@(p:_) = polyline $ lst ++ [p]
rectangle :: Point
-> Float
-> Float
-> [Primitive]
rectangle p@(V2 px py) w h =
LinePrim <$> lineFromPath
[ p, V2 (px + w) py, V2 (px + w) (py + h), V2 px (py + h), p ]
drawImage :: (Pixel px, Modulable (PixelBaseComponent px))
=> Image px
-> StrokeWidth
-> Point
-> Drawing px ()
drawImage img@Image { imageWidth = w, imageHeight = h } s p =
drawImageAtSize img s p (fromIntegral w) (fromIntegral h)
drawImageAtSize :: (Pixel px, Modulable (PixelBaseComponent px))
=> Image px
-> StrokeWidth
-> Point
-> Float
-> Float
-> Drawing px ()
drawImageAtSize img@Image { imageWidth = w, imageHeight = h } borderSize p
reqWidth reqHeight
| borderSize <= 0 =
withTransformation (translate p <> scale scaleX scaleY) .
withTexture (sampledImageTexture img) $ fill rect
| otherwise = do
withTransformation (translate p <> scale scaleX scaleY) $ do
withTexture (sampledImageTexture img) $ fill rect
stroke borderSize (JoinMiter 0)
(CapStraight 0, CapStraight 0) rect'
where
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
roundedRectangle :: Point
-> Float
-> Float
-> Float
-> Float
-> [Primitive]
roundedRectangle (V2 px py) w h rx ry =
[ CubicBezierPrim . transform (^+^ V2 xFar yNear) $ cornerTopR
, LinePrim $ Line (V2 xFar py) (V2 xNear py)
, CubicBezierPrim . transform (^+^ V2 (px + rx) (py + ry)) $ cornerTopL
, LinePrim $ Line (V2 px yNear) (V2 px yFar)
, CubicBezierPrim . transform (^+^ V2 (px + rx) yFar) $ cornerBottomL
, LinePrim $ Line (V2 xNear (py + h)) (V2 xFar (py + h))
, CubicBezierPrim . transform (^+^ V2 xFar yFar) $ cornerBottomR
, LinePrim $ Line (V2 (px + w) yFar) (V2 (px + w) yNear)
]
where
xNear = px + rx
xFar = px + w rx
yNear = py + ry
yFar = py + h ry
(cornerBottomR :
cornerTopR :
cornerTopL :
cornerBottomL:_) = transform (\(V2 x y) -> V2 (x * rx) (y * ry)) <$> cubicBezierCircle
line :: Point -> Point -> [Primitive]
line p1 p2 = [LinePrim $ Line p1 p2]