{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE EmptyDataDecls        #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Image
-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Importing external images into diagrams.  Usage example: To create
-- a diagram from an embedded image with width 1 and height set
-- according to the aspect ratio, use @image img # scaleUToX 1@, where
-- @img@ is a value of type @DImage n e@, created with a function like
-- 'loadImageEmb', 'loadImageExt', or 'raster'.
-----------------------------------------------------------------------------

module Diagrams.TwoD.Image
    (
      DImage(..), ImageData(..)
    , Embedded, External, Native
    , image
    , embeddedImage
    , loadImageEmb
    , loadImageEmbBS
    , loadImageExt
    , uncheckedImageRef
    , raster
    , rasterDia
    ) where

import           Codec.Picture

import           Data.Colour          (AlphaColour)
import           Data.Kind            (Type)
import           Data.Semigroup
import           Data.Typeable        (Typeable)

import           Diagrams.Core

import           Diagrams.Attributes  (colorToSRGBA)
import           Diagrams.Path        (Path)
import           Diagrams.Query
import           Diagrams.TwoD.Path   (isInsideEvenOdd)
import           Diagrams.TwoD.Shapes (rect)
import           Diagrams.TwoD.Types

import           Data.ByteString

import           Linear.Affine

data Embedded deriving Typeable
data External deriving Typeable
data Native (t :: Type) deriving Typeable

-- | 'ImageData' is either a JuicyPixels @DynamicImage@ tagged as 'Embedded' or
--   a reference tagged as 'External'. Additionally 'Native' is provided for
--   external libraries to hook into.
data ImageData :: Type -> Type where
  ImageRaster :: DynamicImage -> ImageData Embedded
  ImageRef    :: FilePath -> ImageData External
  ImageNative :: t -> ImageData (Native t)

-------------------------------------------------------------------------------
-- | An image primitive, the two ints are width followed by height.
--   Will typically be created by @loadImageEmb@ or @loadImageExt@ which,
--   will handle setting the width and height to the actual width and height
--   of the image.
data DImage :: Type -> Type -> Type 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 n a -> Query (V (DImage n a)) (N (DImage n a)) Any
getQuery (DImage ImageData a
_ Int
w Int
h Transformation V2 n
_) = -- transform t $
    forall (v :: * -> *) n m. (Point v n -> m) -> Query v n m
Query forall a b. (a -> b) -> a -> b
$ \Point (V (DImage n a)) (N (DImage n a))
p -> Bool -> Any
Any (forall t. HasQuery t Crossings => t -> Point (V t) (N t) -> Bool
isInsideEvenOdd Path V2 n
r Point (V (DImage n a)) (N (DImage n a))
p)
    where
    r :: Path V2 n
r = forall n. RealFloat n => n -> n -> Path V2 n
rectPath (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)

instance Fractional n => Transformable (DImage n a) where
  transform :: Transformation (V (DImage n a)) (N (DImage n a))
-> DImage n a -> DImage n a
transform Transformation (V (DImage n a)) (N (DImage n a))
t1 (DImage ImageData a
iD Int
w Int
h Transformation V2 n
t2) = forall t n.
ImageData t -> Int -> Int -> Transformation V2 n -> DImage n t
DImage ImageData a
iD Int
w Int
h (Transformation (V (DImage n a)) (N (DImage n a))
t1 forall a. Semigroup a => a -> a -> a
<> Transformation V2 n
t2)

instance Fractional n => HasOrigin (DImage n a) where
  moveOriginTo :: Point (V (DImage n a)) (N (DImage n a)) -> DImage n a -> DImage n a
moveOriginTo Point (V (DImage n a)) (N (DImage n a))
p = forall t. Transformable t => Vn t -> t -> t
translate (forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point (V (DImage n a)) (N (DImage n a))
p)

-- | Make a 'DImage' into a 'Diagram'.
image :: (TypeableFloat n, Typeable a, Renderable (DImage n a) b)
      => DImage n a -> QDiagram b V2 n Any
image :: forall n a b.
(TypeableFloat n, Typeable a, Renderable (DImage n a) b) =>
DImage n a -> QDiagram b V2 n Any
image DImage n a
img
  = forall b (v :: * -> *) n m.
Prim b v n
-> Envelope v n
-> Trace v n
-> SubMap b v n m
-> Query v n m
-> QDiagram b v n m
mkQD (forall p b.
(Transformable p, Typeable p, Renderable p b) =>
p -> Prim b (V p) (N p)
Prim DImage n a
img)
         (forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope Path V2 n
r)
         (forall a. Traced a => a -> Trace (V a) (N a)
getTrace Path V2 n
r)
         forall a. Monoid a => a
mempty
         (forall (v :: * -> *) n m. (Point v n -> m) -> Query v n m
Query forall a b. (a -> b) -> a -> b
$ \Point V2 n
p -> Bool -> Any
Any (forall t. HasQuery t Crossings => t -> Point (V t) (N t) -> Bool
isInsideEvenOdd Path V2 n
r Point V2 n
p))
  where
    r :: Path V2 n
r = forall n. RealFloat n => n -> n -> Path V2 n
rectPath (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
    -- should we use the transform here?
    DImage ImageData a
_ Int
w Int
h Transformation V2 n
_ = DImage n a
img

rectPath :: RealFloat n => n -> n -> Path V2 n
rectPath :: forall n. RealFloat n => n -> n -> Path V2 n
rectPath = forall n t. (InSpace V2 n t, TrailLike t) => n -> n -> t
rect

-- | Read a JuicyPixels @DynamicImage@ and wrap it in a 'DImage'.
--   The width and height of the image are set to their actual values.
embeddedImage :: Num n => DynamicImage -> DImage n Embedded
embeddedImage :: forall n. Num n => DynamicImage -> DImage n Embedded
embeddedImage DynamicImage
img = forall t n.
ImageData t -> Int -> Int -> Transformation V2 n -> DImage n t
DImage (DynamicImage -> ImageData Embedded
ImageRaster DynamicImage
img) Int
w Int
h forall a. Monoid a => a
mempty
  where
    w :: Int
w = forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap forall a. Image a -> Int
imageWidth DynamicImage
img
    h :: Int
h = forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap forall a. Image a -> Int
imageHeight DynamicImage
img

-- | Use JuicyPixels to read a file in any format and wrap it in a 'DImage'.
--   The width and height of the image are set to their actual values.
loadImageEmb :: Num n => FilePath -> IO (Either String (DImage n Embedded))
loadImageEmb :: forall n.
Num n =>
FilePath -> IO (Either FilePath (DImage n Embedded))
loadImageEmb FilePath
path = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall n. Num n => DynamicImage -> DImage n Embedded
embeddedImage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO (Either FilePath DynamicImage)
readImage FilePath
path

-- | A pure variant of 'loadImageEmb'
loadImageEmbBS :: Num n => ByteString -> Either String (DImage n Embedded)
loadImageEmbBS :: forall n.
Num n =>
ByteString -> Either FilePath (DImage n Embedded)
loadImageEmbBS ByteString
bs = forall n. Num n => DynamicImage -> DImage n Embedded
embeddedImage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ByteString -> Either FilePath DynamicImage
decodeImage ByteString
bs

-- | Check that a file exists, and use JuicyPixels to figure out
--   the right size, but save a reference to the image instead
--   of the raster data
loadImageExt :: Num n => FilePath -> IO (Either String (DImage n External))
loadImageExt :: forall n.
Num n =>
FilePath -> IO (Either FilePath (DImage n External))
loadImageExt FilePath
path = do
  Either FilePath DynamicImage
dImg <- FilePath -> IO (Either FilePath DynamicImage)
readImage FilePath
path
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either FilePath DynamicImage
dImg of
    Left FilePath
msg  -> forall a b. a -> Either a b
Left FilePath
msg
    Right DynamicImage
img -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall t n.
ImageData t -> Int -> Int -> Transformation V2 n -> DImage n t
DImage (FilePath -> ImageData External
ImageRef FilePath
path) Int
w Int
h forall a. Monoid a => a
mempty
      where
        w :: Int
w = forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap forall a. Image a -> Int
imageWidth DynamicImage
img
        h :: Int
h = forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap forall a. Image a -> Int
imageHeight DynamicImage
img

-- | Make an "unchecked" image reference; have to specify a
--   width and height. Unless the aspect ratio of the external
--   image is the w :: h, then the image will be distorted.
uncheckedImageRef :: Num n => FilePath -> Int -> Int -> DImage n External
uncheckedImageRef :: forall n. Num n => FilePath -> Int -> Int -> DImage n External
uncheckedImageRef FilePath
path Int
w Int
h = forall t n.
ImageData t -> Int -> Int -> Transformation V2 n -> DImage n t
DImage (FilePath -> ImageData External
ImageRef FilePath
path) Int
w Int
h forall a. Monoid a => a
mempty

-- | Crate a diagram from raw raster data.
rasterDia :: (TypeableFloat n, Renderable (DImage n Embedded) b)
          => (Int -> Int -> AlphaColour Double) -> Int -> Int -> QDiagram b V2 n Any
rasterDia :: forall n b.
(TypeableFloat n, Renderable (DImage n Embedded) b) =>
(Int -> Int -> AlphaColour Double)
-> Int -> Int -> QDiagram b V2 n Any
rasterDia Int -> Int -> AlphaColour Double
f Int
w Int
h = forall n a b.
(TypeableFloat n, Typeable a, Renderable (DImage n a) b) =>
DImage n a -> QDiagram b V2 n Any
image forall a b. (a -> b) -> a -> b
$ forall n.
Num n =>
(Int -> Int -> AlphaColour Double)
-> Int -> Int -> DImage n Embedded
raster Int -> Int -> AlphaColour Double
f Int
w Int
h

-- | Create an image "from scratch" by specifying the pixel data
raster :: Num n => (Int -> Int -> AlphaColour Double) -> Int -> Int -> DImage n Embedded
raster :: forall n.
Num n =>
(Int -> Int -> AlphaColour Double)
-> Int -> Int -> DImage n Embedded
raster Int -> Int -> AlphaColour Double
f Int
w Int
h = forall t n.
ImageData t -> Int -> Int -> Transformation V2 n -> DImage n t
DImage (DynamicImage -> ImageData Embedded
ImageRaster (Image PixelRGBA8 -> DynamicImage
ImageRGBA8 Image PixelRGBA8
img)) Int
w Int
h forall a. Monoid a => a
mempty
  where
    img :: Image PixelRGBA8
img = forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> PixelRGBA8
g Int
w Int
h
    g :: Int -> Int -> PixelRGBA8
g Int
x Int
y = AlphaColour Double -> PixelRGBA8
fromAlphaColour forall a b. (a -> b) -> a -> b
$ Int -> Int -> AlphaColour Double
f Int
x Int
y

fromAlphaColour :: AlphaColour Double -> PixelRGBA8
fromAlphaColour :: AlphaColour Double -> PixelRGBA8
fromAlphaColour AlphaColour Double
c = Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
r Pixel8
g Pixel8
b Pixel8
a
  where
    (Pixel8
r, Pixel8
g, Pixel8
b, Pixel8
a) = (forall {a} {b}. (RealFrac a, Integral b) => a -> b
int Double
r', forall {a} {b}. (RealFrac a, Integral b) => a -> b
int Double
g', forall {a} {b}. (RealFrac a, Integral b) => a -> b
int Double
b', forall {a} {b}. (RealFrac a, Integral b) => a -> b
int Double
a')
    (Double
r', Double
g', Double
b', Double
a') = forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA AlphaColour Double
c
    int :: a -> b
int a
x = forall a b. (RealFrac a, Integral b) => a -> b
round (a
255 forall a. Num a => a -> a -> a
* a
x)

instance Fractional n => (Renderable (DImage n a) NullBackend) where
  render :: NullBackend
-> DImage n a
-> Render NullBackend (V (DImage n a)) (N (DImage n a))
render NullBackend
_ DImage n a
_ = forall a. Monoid a => a
mempty