{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Diagrams.TwoD.Image
(
DImage(..), ImageData(..)
, Embedded, External, Native
, image
, loadImageEmb
, loadImageExt
, uncheckedImageRef
, raster
, rasterDia
) where
import Codec.Picture
import Codec.Picture.Types (dynamicMap)
import Data.Colour (AlphaColour)
import Data.Semigroup
import Data.Typeable (Typeable)
import Diagrams.Core
import Diagrams.Attributes (colorToSRGBA)
import Diagrams.TwoD.Path (isInsideEvenOdd)
import Diagrams.Path (Path)
import Diagrams.TwoD.Shapes (rect)
import Diagrams.Query
import Diagrams.TwoD.Types
import Linear.Affine
data Embedded deriving Typeable
data External deriving Typeable
data Native (t :: *) deriving Typeable
data ImageData :: * -> * where
ImageRaster :: DynamicImage -> ImageData Embedded
ImageRef :: FilePath -> ImageData External
ImageNative :: t -> ImageData (Native t)
data DImage :: * -> * -> * where
DImage :: ImageData t -> Int -> Int -> Transformation V2 n -> DImage n t
deriving Typeable
type instance V (DImage n a) = V2
type instance N (DImage n a) = n
instance RealFloat n => HasQuery (DImage n a) Any where
getQuery (DImage _ w h _) =
Query $ \p -> Any (isInsideEvenOdd r p)
where
r = rectPath (fromIntegral w) (fromIntegral h)
instance Fractional n => Transformable (DImage n a) where
transform t1 (DImage iD w h t2) = DImage iD w h (t1 <> t2)
instance Fractional n => HasOrigin (DImage n a) where
moveOriginTo p = translate (origin .-. p)
image :: (TypeableFloat n, Typeable a, Renderable (DImage n a) b)
=> DImage n a -> QDiagram b V2 n Any
image img
= mkQD (Prim img)
(getEnvelope r)
(getTrace r)
mempty
(Query $ \p -> Any (isInsideEvenOdd r p))
where
r = rectPath (fromIntegral w) (fromIntegral h)
DImage _ w h _ = img
rectPath :: RealFloat n => n -> n -> Path V2 n
rectPath = rect
loadImageEmb :: Num n => FilePath -> IO (Either String (DImage n Embedded))
loadImageEmb path = do
dImg <- readImage path
return $ case dImg of
Left msg -> Left msg
Right img -> Right (DImage (ImageRaster img) w h mempty)
where
w = dynamicMap imageWidth img
h = dynamicMap imageHeight img
loadImageExt :: Num n => FilePath -> IO (Either String (DImage n External))
loadImageExt path = do
dImg <- readImage path
return $ case dImg of
Left msg -> Left msg
Right img -> Right $ DImage (ImageRef path) w h mempty
where
w = dynamicMap imageWidth img
h = dynamicMap imageHeight img
uncheckedImageRef :: Num n => FilePath -> Int -> Int -> DImage n External
uncheckedImageRef path w h = DImage (ImageRef path) w h mempty
rasterDia :: (TypeableFloat n, Renderable (DImage n Embedded) b)
=> (Int -> Int -> AlphaColour Double) -> Int -> Int -> QDiagram b V2 n Any
rasterDia f w h = image $ raster f w h
raster :: Num n => (Int -> Int -> AlphaColour Double) -> Int -> Int -> DImage n Embedded
raster f w h = DImage (ImageRaster (ImageRGBA8 img)) w h mempty
where
img = generateImage g w h
g x y = fromAlphaColour $ f x y
fromAlphaColour :: AlphaColour Double -> PixelRGBA8
fromAlphaColour c = PixelRGBA8 r g b a
where
(r, g, b, a) = (int r', int g', int b', int a')
(r', g', b', a') = colorToSRGBA c
int x = round (255 * x)
instance Fractional n => (Renderable (DImage n a) NullBackend) where
render _ _ = mempty