Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

new-builder #20

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

new-builder #20

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
18 changes: 12 additions & 6 deletions src/Diagrams/Backend/Rasterific.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -90,6 +90,7 @@ import Diagrams.TwoD.Adjust (adjustDia2D)
import Diagrams.TwoD.Attributes (splitTextureFills)
import Diagrams.TwoD.Path (Clip (Clip), getFillRule)
import Diagrams.TwoD.Text hiding (Font)
import Diagrams.Backend.Build

import Codec.Picture
import Codec.Picture.Types (dropTransparency, convertPixel
Expand Down Expand Up @@ -182,6 +183,11 @@ instance Backend Rasterific V2 Float where

adjustDia c opts d = adjustDia2D sizeSpec c opts (d # reflectY # fontSizeO 12)

instance BackendBuild Rasterific V2 Float where
outputSize = sizeSpec
saveDia outFile opts = renderRasterific outFile (opts^.sizeSpec) 80


toRender :: RTree Rasterific V2 Float a -> Render Rasterific V2 Float
toRender = fromRTree
. Node (RStyle (mempty # recommendFillColor (transparent :: AlphaColour Double)))
Expand Down Expand Up @@ -356,7 +362,7 @@ mkStroke l j c d primList =
instance Renderable (Path V2 Float) Rasterific where
render _ p = R $ do
f <- getStyleAttrib getFillTexture
s <- fromMaybe (SC (SomeColor (black :: Colour Double)))
s <- fromMaybe (SC (SomeColor (black :: Colour Double)))
<$> getStyleAttrib getLineTexture
o <- fromMaybe 1 <$> getStyleAttrib getOpacity
r <- fromMaybe Winding <$> getStyleAttrib getFillRule
Expand Down Expand Up @@ -415,7 +421,7 @@ instance Renderable (Text Float) Rasterific where
fs <- fromMaybe 12 <$> getStyleAttrib (getFontSize :: FontSize Float -> Float)
slant <- fromMaybe FontSlantNormal <$> getStyleAttrib getFontSlant
fw <- fromMaybe FontWeightNormal <$> getStyleAttrib getFontWeight
f <- fromMaybe (SC (SomeColor (black :: Colour Double)))
f <- fromMaybe (SC (SomeColor (black :: Colour Double)))
<$> getStyleAttrib getFillTexture
o <- fromMaybe 1 <$> getStyleAttrib getOpacity
let fColor = rasterificTexture f o
Expand Down Expand Up @@ -446,16 +452,16 @@ instance Renderable (DImage Float Embedded) Rasterific where
where
ImageRaster dImg = iD
img = toImageRGBA8 dImg
trl = moveOriginBy (r2 (fromIntegral w / 2, fromIntegral h / 2)) mempty
trl = moveOriginBy (r2 (fromIntegral w / 2, fromIntegral h / 2)) mempty
p = rasterificPtTransf trl (R.V2 0 0)

writeJpeg :: Word8 -> FilePath -> Result Rasterific V2 Float -> IO ()
writeJpeg quality outFile img = L.writeFile outFile bs
where
bs = encodeJpegAtQuality quality (pixelMap (convertPixel . dropTransparency) img)

renderRasterific :: FilePath -> SizeSpec V2 Float -> Word8 -> Diagram Rasterific -> IO ()
renderRasterific outFile spec quality d = writer outFile img
renderRasterific :: FilePath -> SizeSpec V2 Float -> Word8 -> Diagram Rasterific -> IO ()
renderRasterific outFile spec quality d = writer outFile img
where
writer = case takeExtension outFile of
".png" -> writePng
Expand All @@ -464,5 +470,5 @@ renderRasterific outFile spec quality d = writer outFile img
".jpg" -> writeJpeg q
_ -> writePng
img = renderDia Rasterific (RasterificOptions spec) d
q = min quality 100
q = min quality 100