{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE CPP #-}
#if ( __GLASGOW_HASKELL__ < 820 )
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#endif
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Chart.Rect
( RectOptions(..)
, blob
, box
, clear
, bound
, rect_
, rects
, rectChart
, rectChart_
, Pixel(..)
, pixel_
, pixels
, pixelChart
, pixelChart_
, PixelationOptions(..)
, pixelate
, pixelateChart
) where
import Chart.Core
import Diagrams.Prelude hiding (Color, D, (<>), scaleX, scaleY)
import NumHask.Pair
import NumHask.Prelude
import NumHask.Range
import NumHask.Rect
import NumHask.Space
data RectOptions = RectOptions
{ borderSize :: Double
, borderColor :: UColor Double
, color :: UColor Double
} deriving (Show, Generic)
instance Default RectOptions where
def = RectOptions 0.005 ugrey ublue
blob :: UColor Double -> RectOptions
blob c = RectOptions 0 utrans c
clear :: RectOptions
clear = RectOptions 0 utrans utrans
box :: UColor Double -> RectOptions
box c = RectOptions 0.015 c utrans
bound :: RectOptions -> Double -> Chart b -> Chart b
bound (RectOptions bs bc c) p x =
(boundingRect x' # lcA (acolor bc) # lwN bs # fcA (acolor c)) <> x'
where
x' = pad p x
rect_ ::
( N b ~ Double
, V b ~ V2
, Transformable b
, HasOrigin b
, TrailLike b
, HasStyle b
)
=> RectOptions
-> Rect Double
-> b
rect_ (RectOptions bs bc c) (Rect x z y w) =
unitSquare # moveTo (p2 (0.5, 0.5)) # scaleX (z - x) # scaleY (w - y) #
moveTo (p2 (x, y)) #
fcA (acolor c) #
lcA (acolor bc) #
lwN bs
rects ::
( V a ~ V2
, N a ~ Double
, Functor t
, HasStyle a
, TrailLike a
, HasOrigin a
, Transformable a
, Foldable t
, Monoid a
)
=> RectOptions
-> t (Rect Double)
-> a
rects opts xs = mconcat $ toList $ rect_ opts <$> xs
rectChart ::
(Traversable f)
=> [RectOptions]
-> Rect Double
-> Rect Double
-> [f (Rect Double)]
-> Chart b
rectChart optss asp r rs =
mconcat . zipWith rects optss $ fmap (projectRect r asp) <$> rs
rectChart_ ::
(Traversable f)
=> [RectOptions]
-> Rect Double
-> [f (Rect Double)]
-> Chart b
rectChart_ optss asp rs = rectChart optss asp (fold $ fold <$> rs) rs
data Pixel = Pixel
{ pixelRect :: Rect Double
, pixelColor :: UColor Double
} deriving (Show, Generic)
pixel_ :: Pixel -> Chart b
pixel_ (Pixel (Rect x z y w) c) =
unitSquare # moveTo (p2 (0.5, 0.5)) # scaleX (z - x) # scaleY (w - y) #
moveTo (p2 (x, y)) #
fcA (acolor c) #
lcA (acolor utrans) #
lw 0
pixels :: (Traversable f) => f Pixel -> Chart b
pixels ps = mconcat $ toList $ pixel_ <$> ps
pixelChart ::
(Traversable f) => Rect Double -> Rect Double -> [f Pixel] -> Chart b
pixelChart asp r pss = mconcat $ pixels . projectPixels r asp . toList <$> pss
where
projectPixels r0 r1 ps =
zipWith Pixel (projectRect r0 r1 . pixelRect <$> ps) (pixelColor <$> ps)
pixelChart_ :: (Traversable f) => Rect Double -> [f Pixel] -> Chart b
pixelChart_ asp ps = pixelChart asp (fold $ fold . map pixelRect <$> ps) ps
data PixelationOptions = PixelationOptions
{ pixelationGradient :: Range (AlphaColour Double)
, pixelationGrain :: Pair Int
}
instance Default PixelationOptions where
def =
PixelationOptions
(Range (acolor $ UColor 0.47 0.73 0.86 1) (acolor $ UColor 0.01 0.06 0.22 1))
(Pair 40 40)
pixelate ::
PixelationOptions -> Rect Double -> (Pair Double -> Double) -> [Pixel]
pixelate (PixelationOptions (Range lc0 uc0) grain) xy f = zipWith Pixel g (ucolor <$> cs)
where
g = gridSpace xy grain
xs = f . mid <$> g
(Range lx ux) = space xs
cs = (\x -> blend ((x - lx) / (ux - lx)) lc0 uc0) <$> xs
pixelateChart ::
PixelationOptions
-> Rect Double
-> Rect Double
-> (Pair Double -> Double)
-> Chart b
pixelateChart opts asp xy f = pixelChart asp xy [pixelate opts xy f]