module Dihaa.OutputPNG (outputFilePNG) where
import Dihaa
import Dihaa.Vectorize
import TwoD
import Paths_dihaa
import Control.Applicative
import Data.Maybe
import Data.Monoid
import Graphics.Text.TrueType (loadFontFile, Font)
import Codec.Picture( PixelRGBA8( .. ), writePng )
import Graphics.Rasterific
import Graphics.Rasterific.Texture
scaleXFactor :: Int
scaleXFactor = 9
scaleYFactor :: Int
scaleYFactor = 15
margin :: Int
margin = 6
scaleX :: Float -> Float
scaleX = (fromIntegral margin +) . (fromIntegral scaleXFactor *)
scaleY :: Float -> Float
scaleY = (fromIntegral margin +) . (fromIntegral scaleYFactor *)
pToV2 :: Dihaa.Vectorize.Point -> Float -> Graphics.Rasterific.Point
pToV2 (P x y) o = V2 (scaleX (fromIntegral x)
+ (fromIntegral scaleXFactor/2) + o)
(scaleY (fromIntegral y)
+ (fromIntegral scaleYFactor/2) + o)
drawBoxes :: Float -> Maybe PixelRGBA8 -> [Shape] -> Drawing PixelRGBA8 ()
drawBoxes o maybeColor = mconcat . fmap drawBox
where
drawBox (Box p1 p2 (RGB r g b)) = let color = fromJust
$ maybeColor
<|> Just (PixelRGBA8
(fromIntegral r)
(fromIntegral g)
(fromIntegral b) 255)
in
withTexture (uniformTexture color)
$ fill $ rectangle (pToV2 p1 o) (calcW p1 p2) (calcH p1 p2)
drawBox _ = return ()
calcW (P x1 _) (P x2 _) = fromIntegral ((x2 - x1) * scaleXFactor)
calcH (P _ y1) (P _ y2) = fromIntegral ((y2 - y1) * scaleYFactor)
drawLabels :: Float -> Font -> [Shape] -> Drawing px ()
drawLabels o fnt = mconcat . fmap drawLabel
where
drawLabel (Label p s) = let (V2 x y) = pToV2 p o in
printTextAt fnt (PointSize 11.25)
(V2 (x - (fromIntegral scaleXFactor*0.6))
(y + (fromIntegral scaleXFactor*0.5)))
s
drawLabel _ = return ()
drawLines :: Float -> [Shape] -> Drawing px ()
drawLines o = mconcat . fmap drawLine
where
drawLine (Dihaa.Vectorize.Line p1 p2) =
stroke 1 (JoinMiter 0) (CapStraight 1,CapStraight 1) $
line (pToV2 p1 o) (pToV2 p2 o)
drawLine _ = return ()
diaArrow :: Graphics.Rasterific.Point -> TwoD.Direction -> Drawing px ()
diaArrow (V2 x y) dir = fill $ case dir of
N -> polygon [V2 x (y-hH+sp),
V2 (x+hS) (y-hH+sp+fS),
V2 (x-hS) (y-hH+sp+fS)]
S -> polygon [V2 x (y+hH-sp),
V2 (x+hS) (y+hH-sp-fS),
V2 (x-hS) (y+hH-sp-fS)]
W -> polygon [V2 (x-hW+sp) y,
V2 (x-hW+sp+fS) (y-hS),
V2 (x-hW+sp+fS) (y+hS)]
E -> polygon [V2 (x+hW-sp) y,
V2 (x+hW-sp-fS) (y-hS),
V2 (x+hW-sp-fS) (y+hS)]
where
hW = fromIntegral scaleXFactor / 2
hH = fromIntegral scaleYFactor / 2
hS = min hW hH * 0.8
fS = hS * 2
sp = min hW hH * 0.2
drawArrows :: Float -> [Shape] -> Drawing px ()
drawArrows o = mconcat . fmap drawArrow
where
drawArrow (Arrow p1 d) = diaArrow (pToV2 p1 o) d
drawArrow _ = return ()
outputFilePNG :: String -> Dia -> IO ()
outputFilePNG name d = do
fontFileName <- getDataFileName "fonts/DroidSansMono.ttf"
fontErr <- loadFontFile fontFileName
case fontErr of
Left err -> error err
Right font ->
writePng name img
where bgColor = PixelRGBA8 240 240 240 255
black = PixelRGBA8 0 0 0 255
boxColor = PixelRGBA8 255 255 255 255
shdwColor = PixelRGBA8 0 0 0 40
(w,h) = getSize d
vs = vectorize d
img = renderDrawing
(w * scaleXFactor + 2 * margin)
(h * scaleYFactor + 2 * margin)
bgColor
$ drawBoxes 5 (Just shdwColor) vs
>> drawBoxes 0 Nothing vs
>> (withTexture (uniformTexture black)
$ mconcat [drawLines 0 vs,
drawArrows 0 vs,
drawLabels 0 font vs])