Rasterific-0.7.2.1: exec-src/docImageGenerator.hs
import Control.Monad( forM_ )
import Control.Monad.ST( runST )
import Data.Monoid( (<>) )
import Codec.Picture
import Codec.Picture.Types( promoteImage )
import Graphics.Text.TrueType( loadFontFile )
import Graphics.Rasterific
import Graphics.Rasterific.Outline
import Graphics.Rasterific.Texture
import Graphics.Rasterific.Transformations
import Graphics.Rasterific.MeshPatch
import Graphics.Rasterific.Immediate
import System.Directory( createDirectoryIfMissing )
import System.FilePath( (</>) )
import qualified Data.ByteString.Lazy as LB
import qualified Data.Vector as V
import Graphics.Rasterific.Linear( (^+^) )
logo :: Int -> Bool -> Vector -> [Primitive]
logo size inv offset =
toPrimitives . bezierFromPath . way $ map (^+^ offset)
[ (V2 0 is)
, (V2 0 0)
, (V2 is 0)
, (V2 is2 0)
, (V2 is2 is)
, (V2 is2 is2)
, (V2 is is2)
, (V2 0 is2)
, (V2 0 is)
]
where is = fromIntegral size
is2 = is + is
way | inv = reverse
| otherwise = id
backgroundColor :: PixelRGBA8
backgroundColor = PixelRGBA8 255 255 255 255
frontColor, accentColor, accent2Color :: PixelRGBA8
frontColor = PixelRGBA8 0 0x86 0xc1 255
accentColor = PixelRGBA8 0xff 0xf4 0xc1 255
accent2Color = PixelRGBA8 0xFF 0x53 0x73 255
frontTexture, accentTexture, accent2Texture :: Texture PixelRGBA8
frontTexture = uniformTexture frontColor
accentTexture = uniformTexture accentColor
accent2Texture = uniformTexture accent2Color
produceDocImageAtSize :: Int -> Int -> FilePath -> Drawing PixelRGBA8 () -> IO ()
produceDocImageAtSize width height filename drawing = do
putStrLn $ "Producing " <> filename
writePng filename img
writePdf $ filename <> ".draw.pdf"
writeOrderPdf $ filename <> ".order.pdf"
where
img = renderDrawing width height backgroundColor
$ withTexture frontTexture drawing
writeOrderPdf fname =
LB.writeFile fname .
renderOrdersAtDpiToPdf width height 92 $
drawOrdersOfDrawing width height 92 (PixelRGBA8 0 0 0 0) $
withTexture frontTexture drawing
writePdf fname =
LB.writeFile fname .
renderDrawingAtDpiToPDF width height 92 $
withTexture frontTexture drawing
produceDocImage :: FilePath -> Drawing PixelRGBA8 () -> IO ()
produceDocImage = produceDocImageAtSize 200 200
capTester :: (FilePath, Cap) -> IO ()
capTester (filename, cap) =
produceDocImage filename $ do
stroke 30 JoinRound (cap, cap) base_stroke
withTexture accentTexture $
stroke 2 JoinRound (cap, cap) base_stroke
where
base_stroke = line (V2 0 200) (V2 100 100)
joinTester :: (FilePath, Join) -> IO ()
joinTester (filename, join) =
produceDocImage filename $ do
stroke 30 join (CapRound, CapRound) base_stroke
withTexture accentTexture $
stroke 2 join (CapRound, CapRound) base_stroke
where
base_stroke =
[ Line (V2 0 200) (V2 100 100)
, Line (V2 100 100) (V2 200 200)
]
samplerTester :: (FilePath, SamplerRepeat) -> IO ()
samplerTester (filename, sampler) =
produceDocImage filename $
(let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255)
,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255)
,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in
withTexture (withSampler sampler $ linearGradientTexture gradDef
(V2 80 100) (V2 120 110)) $
fill $ rectangle (V2 10 10) 180 180)
outFolder :: FilePath
outFolder = "docimages"
moduleExample :: IO ()
moduleExample = do
let drawColor = PixelRGBA8 0 0x86 0xc1 255
recColor = PixelRGBA8 0xFF 0x53 0x73 255
img =
withTexture (uniformTexture drawColor) $ do
fill $ circle (V2 0 0) 30
stroke 4 JoinRound (CapRound, CapRound) $
circle (V2 400 200) 40
withTexture (uniformTexture recColor) .
fill $ rectangle (V2 100 100) 200 100
produceDocImageAtSize 400 200 (outFolder </> "module_example.png") img
sansSerifFont :: FilePath
sansSerifFont = "test_fonts/DejaVuSans.ttf"
monospaceFont :: FilePath
monospaceFont = "test_fonts/DejaVuSansMono.ttf"
textOnPathExample :: IO ()
textOnPathExample = do
fontErr <- loadFontFile sansSerifFont
case fontErr of
Left err -> putStrLn err
Right font ->
let path = Path (V2 100 180) False
[PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)]
in
produceDocImage (outFolder </> "text_on_path.png") $ do
stroke 3 JoinRound (CapStraight 0, CapStraight 0) path
withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ do
withPathOrientation path 0 $
printTextAt font (PointSize 24) (V2 0 0) "Text on path"
geometryOnPath :: IO ()
geometryOnPath = do
fontErr <- loadFontFile sansSerifFont
case fontErr of
Left err -> putStrLn err
Right font ->
produceDocImage (outFolder </> "geometry_on_path.png") $ do
let path = Path (V2 100 180) False
[PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)]
withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $
stroke 3 JoinRound (CapStraight 0, CapStraight 0) path
withPathOrientation path 0 $ do
printTextAt font (PointSize 24) (V2 0 0) "TX"
fill $ rectangle (V2 (-10) (-10)) 30 20
fill $ rectangle (V2 45 0) 10 20
fill $ rectangle (V2 60 (-10)) 20 20
fill $ rectangle (V2 100 (-15)) 20 50
textExample :: IO ()
textExample = do
fontErr <- loadFontFile sansSerifFont
case fontErr of
Left err -> putStrLn err
Right font ->
produceDocImageAtSize 300 70 (outFolder </> "text_example.png")
. withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $
printTextAt font (PointSize 12) (V2 20 40) "A simple text test!"
textMultipleExample :: IO ()
textMultipleExample = do
eitherFont1 <- loadFontFile sansSerifFont
eitherFont2 <- loadFontFile monospaceFont
case (,) <$> eitherFont1 <*> eitherFont2 of
Left err -> putStrLn err
Right (font1, font2) ->
produceDocImageAtSize 300 70 (outFolder </> "text_complex_example.png") $
let blackTexture =
Just . uniformTexture $ PixelRGBA8 0 0 0 255
redTexture =
Just . uniformTexture $ PixelRGBA8 255 0 0 255
in
printTextRanges (V2 20 40)
[ TextRange font1 (PointSize 12) "A complex " blackTexture
, TextRange font2 (PointSize 8) "text test" redTexture]
coordinateSystem :: IO ()
coordinateSystem = do
fontErr <- loadFontFile sansSerifFont
case fontErr of
Left err -> putStrLn err
Right font ->
produceDocImage (outFolder </> "coordinate.png") $ create font
where
black = PixelRGBA8 0 0 0 255
stroker = stroke 4 JoinRound (CapStraight 0, CapStraight 0)
create font = withTexture (uniformTexture black) $ do
stroker $ line (V2 10 40) (V2 190 40)
stroker $ line (V2 40 10) (V2 40 190)
printTextAt font (PointSize 12) (V2 4 37) "(0,0)"
printTextAt font (PointSize 12) (V2 100 37) "(width, 0)"
printTextAt font (PointSize 12) (V2 57 190) "(0, height)"
fill $ Path (V2 170 30) True
[PathLineTo (V2 195 40), PathLineTo (V2 170 50)]
fill $ Path (V2 30 170) True
[PathLineTo (V2 40 195), PathLineTo (V2 50 170)]
fillingSample :: FillMethod -> Drawing px ()
fillingSample fillMethod = fillWithMethod fillMethod geometry where
geometry = transform (applyTransformation $ scale 0.35 0.4
<> translate (V2 (-80) (-180)))
[ Path (V2 484 499) True
[ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314)
, PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499)
]
, Path (V2 136 377) True
[ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489)
, PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377)
]
, Path (V2 340 265) True
[ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536)
, PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575)
, PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265)
]
]
immediateDrawExample :: Image PixelRGBA8
immediateDrawExample = runST $
runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $
fillWithTexture FillWinding texture geometry
where
circlePrimitives = circle (V2 100 100) 50
geometry = strokize 4 JoinRound (CapRound, CapRound) circlePrimitives
texture = uniformTexture (PixelRGBA8 255 255 255 255)
immediateDrawMaskExample :: Image PixelRGBA8
immediateDrawMaskExample = runST $
runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $
forM_ [1 .. 10] $ \ix ->
fillWithTextureAndMask FillWinding texture mask $
rectangle (V2 10 (ix * 18 - 5)) 180 13
where
texture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255
mask = sampledImageTexture
$ runST
$ runDrawContext 200 200 0
$ fillWithTexture FillWinding (uniformTexture 255) maskGeometry
maskGeometry = strokize 15 JoinRound (CapRound, CapRound)
$ circle (V2 100 100) 80
main :: IO ()
main = do
let addFolder (p, v) = (outFolder </> p, v)
createDirectoryIfMissing True outFolder
moduleExample
mapM_ (capTester . addFolder)
[ ("cap_straight.png", CapStraight 0)
, ("cap_straight_1.png", CapStraight 1)
, ("cap_round.png", CapRound)
]
mapM_ (joinTester . addFolder)
[ ("join_round.png", JoinRound)
, ("join_miter.png", JoinMiter 0)
, ("join_miter_5.png", JoinMiter 5)
]
mapM_ (samplerTester . addFolder)
[ ("sampler_pad.png", SamplerPad)
, ("sampler_repeat.png", SamplerRepeat)
, ("sampler_reflect.png", SamplerReflect)
]
writePng (outFolder </> "immediate_fill.png") immediateDrawExample
writePng (outFolder </> "immediate_mask.png") immediateDrawMaskExample
produceDocImage (outFolder </> "fill_circle.png") $
fill $ circle (V2 100 100) 75
produceDocImage (outFolder </> "fill_ellipse.png") $
fill $ ellipse (V2 100 100) 75 30
produceDocImage (outFolder </> "stroke_circle.png") $
stroke 5 JoinRound (CapRound, CapRound) $ circle (V2 100 100) 75
produceDocImage (outFolder </> "dashed_stroke.png") $
dashedStroke [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $
line (V2 0 100) (V2 200 100)
produceDocImage (outFolder </> "dashed_stroke_with_offset.png") $
dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $
line (V2 0 100) (V2 200 100)
produceDocImage (outFolder </> "fill_rect.png") $
fill $ rectangle (V2 30 30) 150 100
produceDocImage (outFolder </> "with_texture.png") $
withTexture frontTexture $ do
fill $ circle (V2 50 50) 20
fill $ circle (V2 100 100) 20
withTexture accent2Texture $
fill $ circle (V2 150 150) 20
produceDocImage (outFolder </> "strokize_path.png") $
stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0) $
strokize 40 JoinRound (CapRound, CapRound) $
CubicBezier (V2 40 160) (V2 40 40)
(V2 160 40) (V2 160 160)
produceDocImage (outFolder </> "strokize_dashed_path.png") $
mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $
dashedStrokize 0 [10, 5]
40 JoinRound (CapStraight 0, CapStraight 0)
[CubicBezier (V2 40 160) (V2 40 40)
(V2 160 40) (V2 160 160)]
produceDocImage (outFolder </> "with_clipping.png") $
withClipping (fill $ circle (V2 100 100) 75) $
mapM_ (stroke 7 JoinRound (CapRound, CapRound))
[line (V2 0 yf) (V2 200 (yf + 10))
| y <- [5 :: Int, 17 .. 200]
, let yf = fromIntegral y ]
{-produceDocImage (outFolder </> "clip_compose.png") $-}
produceDocImage (outFolder </> "stroke_line.png") $
stroke 17 JoinRound (CapRound, CapRound) $
line (V2 10 10) (V2 180 170)
produceDocImage (outFolder </> "linear_gradient.png") $
(let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255)
,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255)
,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in
withTexture (linearGradientTexture gradDef (V2 40 40) (V2 130 130)) $
fill $ circle (V2 100 100) 100)
produceDocImage (outFolder </> "radial_gradient.png") $
(let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255)
,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255)
,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in
withTexture (radialGradientTexture gradDef (V2 100 100) 75) $
fill $ circle (V2 100 100) 100)
produceDocImage (outFolder </> "radial_gradient_focus.png") $
(let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255)
,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255)
,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in
withTexture (radialGradientWithFocusTexture gradDef (V2 100 100) 75 (V2 70 70)) $
fill $ circle (V2 100 100) 100)
produceDocImage (outFolder </> "sampler_pad.png") $
(let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255)
,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255)
,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in
withTexture (linearGradientTexture gradDef (V2 80 100) (V2 120 110)) $
fill $ rectangle (V2 10 10) 180 180)
produceDocImage (outFolder </> "logo.png") $ do
let colorCycle = cycle
[ PixelRGBA8 0 0x86 0xc1 255
, PixelRGBA8 0xff 0xf4 0xc1 255
, PixelRGBA8 0 0x86 0xc1 255
, PixelRGBA8 0xDf 0xD4 0xc1 255
, PixelRGBA8 0 0x86 0xc1 255
, PixelRGBA8 0 0x86 0xc1 255]
colors = V.fromListN (4 * 4) colorCycle
mesh = generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors
withTexture (transformTexture (scale 0.7 0.7 <> rotateCenter (-0.4) (V2 100 100)) $
meshPatchTexture PatchBicubic mesh) $
fill $ logo 80 False (V2 20 20) ++
logo 40 True (V2 40 40)
produceDocImage (outFolder </> "cubic_bezier.png") $
stroke 5 JoinRound (CapRound, CapRound) $
CubicBezier (V2 0 10) (V2 205 250)
(V2 (-10) 250) (V2 160 35)
produceDocImage (outFolder </> "quadratic_bezier.png") $
fill [ Bezier (V2 10 10) (V2 200 50) (V2 200 100)
, Bezier (V2 200 100) (V2 150 200) (V2 120 175)
, Bezier (V2 120 175) (V2 30 100) (V2 10 10)]
produceDocImage (outFolder </> "simple_line.png") $
fill [ Line (V2 10 10) (V2 190 10)
, Line (V2 190 10) (V2 95 170)
, Line (V2 95 170) (V2 10 10) ]
produceDocImage (outFolder </> "primitive_mixed.png") $
fill
[ toPrim $ CubicBezier (V2 50 20) (V2 90 60)
(V2 5 100) (V2 50 140)
, toPrim $ Line (V2 50 140) (V2 120 80)
, toPrim $ Line (V2 120 80) (V2 50 20) ]
produceDocImage (outFolder </> "path_example.png") $
fill $ Path (V2 50 20) True
[ PathCubicBezierCurveTo (V2 90 60) (V2 5 100) (V2 50 140)
, PathLineTo (V2 120 80) ]
produceDocImage (outFolder </> "stroke_polyline.png") $
stroke 4 JoinRound (CapRound, CapRound) $
polyline [V2 10 10, V2 100 70, V2 190 190]
produceDocImage (outFolder </> "fill_polygon.png") $
fill $ polygon [V2 30 30, V2 100 70, V2 80 170]
produceDocImage (outFolder </> "fill_roundedRectangle.png") $
fill $ roundedRectangle (V2 10 10) 150 150 20 10
produceDocImage (outFolder </> "stroke_roundedRectangle.png") $
stroke 4 JoinRound (CapRound, CapRound) $
roundedRectangle (V2 10 10) 150 150 20 10
produceDocImage (outFolder </> "fill_evenodd.png") $
fillingSample FillEvenOdd
produceDocImage (outFolder </> "fill_winding.png") $
fillingSample FillWinding
produceDocImage (outFolder </> "transform_rotate.png") $
fill . transform (applyTransformation $ rotate 0.2)
$ rectangle (V2 40 40) 120 120
produceDocImage (outFolder </> "transform_rotate_center.png") $
fill . transform (applyTransformation $ rotateCenter 0.2 (V2 200 200))
$ rectangle (V2 40 40) 120 120
produceDocImage (outFolder </> "transform_translate.png") $
fill . transform (applyTransformation $ translate (V2 100 100))
$ rectangle (V2 40 40) 40 40
produceDocImage (outFolder </> "transform_scale.png") $
fill . transform (applyTransformation $ scale 2 2)
$ rectangle (V2 40 40) 40 40
produceDocImage (outFolder </> "transform_skewx.png") $
fill . transform (applyTransformation $ skewX 0.3)
$ rectangle (V2 50 50) 80 80
produceDocImage (outFolder </> "transform_skewy.png") $
fill . transform (applyTransformation $ skewY 0.3)
$ rectangle (V2 50 50) 80 80
Right (ImageRGB8 img) <- readImage "avatar.png"
let textureImage = promoteImage img
produceDocImage (outFolder </> "sampled_texture_repeat.png") $
withTexture (withSampler SamplerRepeat $
sampledImageTexture textureImage) $
fill $ rectangle (V2 0 0) 200 200
produceDocImage (outFolder </> "image_simple.png") $
drawImage textureImage 0 (V2 30 30)
produceDocImage (outFolder </> "image_resize.png") $
drawImageAtSize textureImage 2 (V2 30 30) 128 128
produceDocImage (outFolder </> "sampled_texture_reflect.png") $
withTexture (withSampler SamplerReflect $
sampledImageTexture textureImage) $
fill $ rectangle (V2 0 0) 200 200
produceDocImage (outFolder </> "sampled_texture_pad.png") $
withTexture (sampledImageTexture textureImage) $
fill $ rectangle (V2 0 0) 200 200
produceDocImage (outFolder </> "sampled_texture_rotate.png") $
withTexture (withSampler SamplerRepeat $
transformTexture (rotateCenter 1 (V2 0 0))
$ sampledImageTexture textureImage) $
fill $ rectangle (V2 0 0) 200 200
produceDocImage (outFolder </> "sampled_texture_scaled.png") $
withTexture (withSampler SamplerRepeat $
transformTexture (rotateCenter 1 (V2 0 0) <>
scale 0.5 0.25)
$ sampledImageTexture textureImage) $
fill $ rectangle (V2 0 0) 200 200
produceDocImage (outFolder </> "group_opacity.png") $ do
withTexture accent2Texture $
stroke 3 JoinRound (CapRound, CapRound) $
line (V2 0 100) (V2 200 100)
withGroupOpacity 128 $ do
withTexture frontTexture . fill $ circle (V2 70 100) 60
withTexture accentTexture . fill $ circle (V2 120 100) 60
produceDocImage (outFolder </> "pattern_texture.png") $
let pattern =
patternTexture 40 40 96 accent2Color .
withTexture frontTexture $
fill $ circle (V2 20 20) 13
in
withTexture pattern $
fill $ roundedRectangle (V2 20 20) 160 160 20 20
produceDocImage (outFolder </> "item_opacity.png") $ do
withTexture accent2Texture $
stroke 3 JoinRound (CapRound, CapRound) $
line (V2 0 100) (V2 200 100)
withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 128) .
fill $ circle (V2 70 100) 60
withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 128) .
fill $ circle (V2 120 100) 60
produceDocImage (outFolder </> "mesh_patch_interp_bilinear.png") $ do
let colorCycle = cycle
[ PixelRGBA8 0 0x86 0xc1 255
, PixelRGBA8 0xff 0xf4 0xc1 255
, PixelRGBA8 0xFF 0x53 0x73 255
, PixelRGBA8 0xff 0xf4 0xc1 255
, PixelRGBA8 0 0x86 0xc1 255]
colors = V.fromListN (4 * 4) colorCycle
withTransformation (rotate 0.2) $
renderMeshPatch PatchBilinear $
generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors
produceDocImage (outFolder </> "mesh_patch_interp_clip.png") $ do
let colorCycle = cycle
[ PixelRGBA8 0 0x86 0xc1 255
, PixelRGBA8 0xff 0xf4 0xc1 255
, PixelRGBA8 0xFF 0x53 0x73 255
, PixelRGBA8 0xff 0xf4 0xc1 255
, PixelRGBA8 0 0x86 0xc1 255]
colors = V.fromListN (4 * 4) colorCycle
withClipping (fill $ circle (V2 100 100) 75) $
renderMeshPatch PatchBilinear $
generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors
produceDocImage (outFolder </> "mesh_patch_interp_bicubic.png") $ do
let colorCycle = cycle
[ PixelRGBA8 0 0x86 0xc1 255
, PixelRGBA8 0xff 0xf4 0xc1 255
, PixelRGBA8 0xFF 0x53 0x73 255
, PixelRGBA8 0xff 0xf4 0xc1 255
, PixelRGBA8 0 0x86 0xc1 255]
colors = V.fromListN (4 * 4) colorCycle
renderMeshPatch PatchBicubic $ generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors
produceDocImage (outFolder </> "mesh_patch_transp.png") $ do
let colorCycle = cycle
[ PixelRGBA8 0 0x86 0xc1 255
, PixelRGBA8 0xff 0xf4 0xc1 255
, PixelRGBA8 0xFF 0x53 0x73 127
, PixelRGBA8 0xff 0xf4 0xc1 127
]
colors = V.fromListN (1 * 4) colorCycle
withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $
fill $ rectangle (V2 0 70) 200 60
renderMeshPatch PatchBicubic $
generateLinearGrid 1 1 (V2 10 10) (V2 180 180) colors
textExample
textMultipleExample
coordinateSystem
textOnPathExample
geometryOnPath