module Graphics.Curves.Render where
import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.List
import qualified Data.ByteString.Lazy as B
import Data.Function
import qualified Codec.Picture as Codec
import qualified Codec.Picture.Png as Codec
import Graphics.Curves.Math
import Graphics.Curves.BoundingBox
import Graphics.Curves.Image
import Graphics.Curves.Compile
import Graphics.Curves.Colour
import Graphics.Curves.Curve
import Debug.Trace
sampleSegments :: FillStyle -> Segments -> Point -> Maybe Colour
sampleSegments (FillStyle varFillColour fillBlur texBasis (LineStyle lineColour lineWidth lineBlur)) s p@(Vec x y) =
case isLine of
Nothing -> edge <|> fill
where
edge = do
let b = fillBlur / 2
d <- distanceAtMost b s p
guard (d < b)
let o | isJust fill = 1 (b d) / fillBlur
| otherwise = 1 (b + d) / fillBlur
return $ opacity o fillColour
Just (α, c) -> Just $ opacity (getAlpha c) $ addFill (getAlpha c) $ setAlpha α c
where
fillColour = getFillColour varFillColour p (toBasis texBasis p)
isZero x = round (255 * x) == 0
isLine = do
(d, seg) <- closestSeg (lineWidth/2 + lineBlur) s p
let LineStyle c w b = annotation seg
inner = w/2
outer = inner + b
α | d <= inner = 1
| d > outer = 0
| otherwise = 1 (d inner) / b
guard $ α > 0
guard $ not $ isZero (getAlpha c)
return (α, c)
closestSeg d s p =
case distanceAtMost' (lineWidth/2 + lineBlur) s p of
[] -> Nothing
cands -> Just $ minimumBy (compare `on` dist) cands
where
dist (d, AnnSeg (LineStyle _ w b) _) = (d w/2) / b
hasFill = not $ isZero $ getAlpha fillColour
addFill α' c = maybe c (blend c . opacity (1/α')) fill
fill | hasFill && odd (length ps) = Just fillColour
| otherwise = Nothing
where
BBox x0 _ _ _ = bounds s
ray = Seg (Vec (x0 1) y) p
ps | insideBBox p (bounds s) = intersectBBTree (\r l -> maybe [] (:[]) $ intersectSegment r (theSegment l)) ray s
| otherwise = []
sampleBBTree :: (a -> Point -> b) -> BBTree a -> Point -> [b]
sampleBBTree sample (Leaf x) p = [sample x p]
sampleBBTree sample (Node b l r) p
| p `insideBBox` b = sampleBBTree sample l p ++ sampleBBTree sample r p
| otherwise = []
sampleImage :: CompiledImage -> Point -> Maybe Colour
sampleImage CIEmpty p = Nothing
sampleImage (Segments style s) p = sampleSegments style s p
sampleImage (CIUnion blend b l r) p
| not $ insideBBox p b = Nothing
| otherwise = blend (sampleImage l p) (sampleImage r p)
type Pixel = Codec.PixelRGBA8
toRGBA :: Colour -> Codec.PixelRGBA8
toRGBA (Colour r g b a) = Codec.PixelRGBA8 (f r) (f g) (f b) (f a)
where
f x = round (255 * x)
renderCompiledImage :: Int -> Int -> Colour -> CompiledImage -> Codec.Image Pixel
renderCompiledImage w h bg0 i =
Codec.generateImage (\x y -> sample (Vec (fromIntegral x) (fromIntegral $ h 1 y))) w h
where
bg = opaque bg0
sample p = toRGBA $ case sampleImage i p of
Nothing -> bg0
Just c -> blend (truncColour c) bg
saveImage :: FilePath -> Codec.Image Codec.PixelRGBA8 -> IO ()
saveImage file img = B.writeFile file (Codec.encodePng img)
renderImage :: FilePath
-> Int
-> Int
-> Colour
-> Image
-> IO ()
renderImage file w h bg i = saveImage file $ renderCompiledImage w h bg $ compileImage i