{-# LANGUAGE BangPatterns
           , CPP
           , FlexibleContexts
           , FlexibleInstances
           , MultiParamTypeClasses
           , PatternGuards
           , TypeFamilies
           , UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Vision.Image.Type (
    -- * Manifest images
      Manifest (..)
    -- * Delayed images
    , Delayed (..)
    -- * Delayed masked images
    , DelayedMask (..)
    -- * Conversion and type helpers
    , delay, compute, delayed, manifest
    ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif

import Control.DeepSeq (NFData (..))
import Data.Convertible (Convertible (..), convert)
import Data.Vector.Storable (Vector, create, enumFromN, forM_, generate)
import Data.Vector.Storable.Mutable (new, write)
import Foreign.Storable (Storable)
import Prelude hiding (map, read)

import qualified Data.Vector.Storable as V

import Vision.Image.Class (
      MaskedImage (..), Image (..), FromFunction (..), FunctorImage (..), (!)
    )
import Vision.Primitive (Z (..), (:.) (..), Point, Size, ix2)

-- Manifest images -------------------------------------------------------------

-- | Stores the image content in a 'Vector'.
data Manifest p = Manifest {
      forall p. Manifest p -> Size
manifestSize   :: !Size
    , forall p. Manifest p -> Vector p
manifestVector :: !(Vector p)
    } deriving (Manifest p -> Manifest p -> Bool
forall p. (Storable p, Eq p) => Manifest p -> Manifest p -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Manifest p -> Manifest p -> Bool
$c/= :: forall p. (Storable p, Eq p) => Manifest p -> Manifest p -> Bool
== :: Manifest p -> Manifest p -> Bool
$c== :: forall p. (Storable p, Eq p) => Manifest p -> Manifest p -> Bool
Eq, Manifest p -> Manifest p -> Bool
Manifest p -> Manifest p -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {p}. (Storable p, Ord p) => Eq (Manifest p)
forall p. (Storable p, Ord p) => Manifest p -> Manifest p -> Bool
forall p.
(Storable p, Ord p) =>
Manifest p -> Manifest p -> Ordering
forall p.
(Storable p, Ord p) =>
Manifest p -> Manifest p -> Manifest p
min :: Manifest p -> Manifest p -> Manifest p
$cmin :: forall p.
(Storable p, Ord p) =>
Manifest p -> Manifest p -> Manifest p
max :: Manifest p -> Manifest p -> Manifest p
$cmax :: forall p.
(Storable p, Ord p) =>
Manifest p -> Manifest p -> Manifest p
>= :: Manifest p -> Manifest p -> Bool
$c>= :: forall p. (Storable p, Ord p) => Manifest p -> Manifest p -> Bool
> :: Manifest p -> Manifest p -> Bool
$c> :: forall p. (Storable p, Ord p) => Manifest p -> Manifest p -> Bool
<= :: Manifest p -> Manifest p -> Bool
$c<= :: forall p. (Storable p, Ord p) => Manifest p -> Manifest p -> Bool
< :: Manifest p -> Manifest p -> Bool
$c< :: forall p. (Storable p, Ord p) => Manifest p -> Manifest p -> Bool
compare :: Manifest p -> Manifest p -> Ordering
$ccompare :: forall p.
(Storable p, Ord p) =>
Manifest p -> Manifest p -> Ordering
Ord, Int -> Manifest p -> ShowS
forall p. (Show p, Storable p) => Int -> Manifest p -> ShowS
forall p. (Show p, Storable p) => [Manifest p] -> ShowS
forall p. (Show p, Storable p) => Manifest p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Manifest p] -> ShowS
$cshowList :: forall p. (Show p, Storable p) => [Manifest p] -> ShowS
show :: Manifest p -> String
$cshow :: forall p. (Show p, Storable p) => Manifest p -> String
showsPrec :: Int -> Manifest p -> ShowS
$cshowsPrec :: forall p. (Show p, Storable p) => Int -> Manifest p -> ShowS
Show)

instance NFData (Manifest p) where
    rnf :: Manifest p -> ()
rnf !Manifest p
_ = ()

instance Storable p => MaskedImage (Manifest p) where
    type ImagePixel (Manifest p) = p

    shape :: Manifest p -> Size
shape = forall p. Manifest p -> Size
manifestSize
    {-# INLINE shape #-}

    Manifest Size
_ Vector p
vec maskedLinearIndex :: Manifest p -> Int -> Maybe (ImagePixel (Manifest p))
`maskedLinearIndex` Int
ix = Vector p
vec forall a. Storable a => Vector a -> Int -> Maybe a
V.!? Int
ix
    {-# INLINE maskedLinearIndex #-}

    values :: Manifest p -> Vector (ImagePixel (Manifest p))
values = forall p. Manifest p -> Vector p
manifestVector
    {-# INLINE values #-}

instance Storable p => Image (Manifest p) where
    Manifest Size
_ Vector p
vec linearIndex :: Manifest p -> Int -> ImagePixel (Manifest p)
`linearIndex` Int
ix = Vector p
vec forall a. Storable a => Vector a -> Int -> a
V.! Int
ix
    {-# INLINE linearIndex #-}

    vector :: Manifest p -> Vector (ImagePixel (Manifest p))
vector = forall p. Manifest p -> Vector p
manifestVector
    {-# INLINE vector #-}

instance Storable p => FromFunction (Manifest p) where
    type FromFunctionPixel (Manifest p) = p

    fromFunction :: Size -> (Size -> FromFunctionPixel (Manifest p)) -> Manifest p
fromFunction !size :: Size
size@(DIM0
Z :. Int
h :. Int
w) Size -> FromFunctionPixel (Manifest p)
f =
        forall p. Size -> Vector p -> Manifest p
Manifest Size
size forall a b. (a -> b) -> a -> b
$ forall a. Storable a => (forall s. ST s (MVector s a)) -> Vector a
create forall a b. (a -> b) -> a -> b
$ do
            MVector s p
arr <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
new (Int
h forall a. Num a => a -> a -> a
* Int
w)

            forall (m :: * -> *) a b.
(Monad m, Storable a) =>
Vector a -> (a -> m b) -> m ()
forM_ (forall a. (Storable a, Num a) => a -> Int -> Vector a
enumFromN Int
0 Int
h) forall a b. (a -> b) -> a -> b
$ \Int
y -> do
                let !lineOffset :: Int
lineOffset = Int
y forall a. Num a => a -> a -> a
* Int
w
                forall (m :: * -> *) a b.
(Monad m, Storable a) =>
Vector a -> (a -> m b) -> m ()
forM_ (forall a. (Storable a, Num a) => a -> Int -> Vector a
enumFromN Int
0 Int
w) forall a b. (a -> b) -> a -> b
$ \Int
x -> do
                    let !offset :: Int
offset = Int
lineOffset forall a. Num a => a -> a -> a
+ Int
x
                        !val :: FromFunctionPixel (Manifest p)
val    = Size -> FromFunctionPixel (Manifest p)
f (Int -> Int -> Size
ix2 Int
y Int
x)
                    forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
write MVector s p
arr Int
offset FromFunctionPixel (Manifest p)
val

            forall (m :: * -> *) a. Monad m => a -> m a
return MVector s p
arr
    {-# INLINE fromFunction #-}

    fromFunctionLine :: forall a.
Size
-> (Int -> a)
-> (a -> Size -> FromFunctionPixel (Manifest p))
-> Manifest p
fromFunctionLine !size :: Size
size@(DIM0
Z :. Int
h :. Int
w) Int -> a
line a -> Size -> FromFunctionPixel (Manifest p)
f =
        forall p. Size -> Vector p -> Manifest p
Manifest Size
size forall a b. (a -> b) -> a -> b
$ forall a. Storable a => (forall s. ST s (MVector s a)) -> Vector a
create forall a b. (a -> b) -> a -> b
$ do
            -- Note: create is faster than unfoldrN.
            MVector s p
arr <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
new (Int
h forall a. Num a => a -> a -> a
* Int
w)

            forall (m :: * -> *) a b.
(Monad m, Storable a) =>
Vector a -> (a -> m b) -> m ()
forM_ (forall a. (Storable a, Num a) => a -> Int -> Vector a
enumFromN Int
0 Int
h) forall a b. (a -> b) -> a -> b
$ \Int
y -> do
                let !lineVal :: a
lineVal    = Int -> a
line Int
y
                    !lineOffset :: Int
lineOffset = Int
y forall a. Num a => a -> a -> a
* Int
w
                forall (m :: * -> *) a b.
(Monad m, Storable a) =>
Vector a -> (a -> m b) -> m ()
forM_ (forall a. (Storable a, Num a) => a -> Int -> Vector a
enumFromN Int
0 Int
w) forall a b. (a -> b) -> a -> b
$ \Int
x -> do
                    let !offset :: Int
offset = Int
lineOffset forall a. Num a => a -> a -> a
+ Int
x
                        !val :: FromFunctionPixel (Manifest p)
val    = a -> Size -> FromFunctionPixel (Manifest p)
f a
lineVal (Int -> Int -> Size
ix2 Int
y Int
x)
                    forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
write MVector s p
arr Int
offset FromFunctionPixel (Manifest p)
val

            forall (m :: * -> *) a. Monad m => a -> m a
return MVector s p
arr
    {-# INLINE fromFunctionLine #-}

    fromFunctionCol :: forall b.
Storable b =>
Size
-> (Int -> b)
-> (b -> Size -> FromFunctionPixel (Manifest p))
-> Manifest p
fromFunctionCol !size :: Size
size@(DIM0
Z :. Int
h :. Int
w) Int -> b
col b -> Size -> FromFunctionPixel (Manifest p)
f =
        forall p. Size -> Vector p -> Manifest p
Manifest Size
size forall a b. (a -> b) -> a -> b
$ forall a. Storable a => (forall s. ST s (MVector s a)) -> Vector a
create forall a b. (a -> b) -> a -> b
$ do
            -- Note: create is faster than unfoldrN.
            MVector s p
arr <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
new (Int
h forall a. Num a => a -> a -> a
* Int
w)

            forall (m :: * -> *) a b.
(Monad m, Storable a) =>
Vector a -> (a -> m b) -> m ()
forM_ (forall a. (Storable a, Num a) => a -> Int -> Vector a
enumFromN Int
0 Int
h) forall a b. (a -> b) -> a -> b
$ \Int
y -> do
                let !lineOffset :: Int
lineOffset = Int
y forall a. Num a => a -> a -> a
* Int
w
                forall (m :: * -> *) a b.
(Monad m, Storable a) =>
Vector a -> (a -> m b) -> m ()
forM_ (forall a. (Storable a, Num a) => a -> Int -> Vector a
enumFromN Int
0 Int
w) forall a b. (a -> b) -> a -> b
$ \Int
x -> do
                    let !offset :: Int
offset = Int
lineOffset forall a. Num a => a -> a -> a
+ Int
x
                        !val :: FromFunctionPixel (Manifest p)
val    = b -> Size -> FromFunctionPixel (Manifest p)
f (Vector b
cols forall a. Storable a => Vector a -> Int -> a
V.! Int
x) (Int -> Int -> Size
ix2 Int
y Int
x)
                    forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
write MVector s p
arr Int
offset FromFunctionPixel (Manifest p)
val

            forall (m :: * -> *) a. Monad m => a -> m a
return MVector s p
arr
      where
        !cols :: Vector b
cols = forall a. Storable a => Int -> (Int -> a) -> Vector a
generate Int
w Int -> b
col
    {-# INLINE fromFunctionCol #-}

    fromFunctionCached :: forall b a.
Storable b =>
Size
-> (Int -> a)
-> (Int -> b)
-> (a -> b -> Size -> FromFunctionPixel (Manifest p))
-> Manifest p
fromFunctionCached !size :: Size
size@(DIM0
Z :. Int
h :. Int
w) Int -> a
line Int -> b
col a -> b -> Size -> FromFunctionPixel (Manifest p)
f =
        forall p. Size -> Vector p -> Manifest p
Manifest Size
size forall a b. (a -> b) -> a -> b
$ forall a. Storable a => (forall s. ST s (MVector s a)) -> Vector a
create forall a b. (a -> b) -> a -> b
$ do
            -- Note: create is faster than unfoldrN.
            MVector s p
arr <- forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
new (Int
h forall a. Num a => a -> a -> a
* Int
w)

            forall (m :: * -> *) a b.
(Monad m, Storable a) =>
Vector a -> (a -> m b) -> m ()
forM_ (forall a. (Storable a, Num a) => a -> Int -> Vector a
enumFromN Int
0 Int
h) forall a b. (a -> b) -> a -> b
$ \Int
y -> do
                let !lineVal :: a
lineVal    = Int -> a
line Int
y
                    !lineOffset :: Int
lineOffset = Int
y forall a. Num a => a -> a -> a
* Int
w
                forall (m :: * -> *) a b.
(Monad m, Storable a) =>
Vector a -> (a -> m b) -> m ()
forM_ (forall a. (Storable a, Num a) => a -> Int -> Vector a
enumFromN Int
0 Int
w) forall a b. (a -> b) -> a -> b
$ \Int
x -> do
                    let !offset :: Int
offset = Int
lineOffset forall a. Num a => a -> a -> a
+ Int
x
                        !val :: FromFunctionPixel (Manifest p)
val    = a -> b -> Size -> FromFunctionPixel (Manifest p)
f a
lineVal (Vector b
cols forall a. Storable a => Vector a -> Int -> a
V.! Int
x) (Int -> Int -> Size
ix2 Int
y Int
x)
                    forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
write MVector s p
arr Int
offset FromFunctionPixel (Manifest p)
val

            forall (m :: * -> *) a. Monad m => a -> m a
return MVector s p
arr
      where
        !cols :: Vector b
cols = forall a. Storable a => Int -> (Int -> a) -> Vector a
generate Int
w Int -> b
col
    {-# INLINE fromFunctionCached #-}

instance (Image src, Storable p) => FunctorImage src (Manifest p) where
    map :: (ImagePixel src -> ImagePixel (Manifest p)) -> src -> Manifest p
map ImagePixel src -> ImagePixel (Manifest p)
f src
img = forall i.
FromFunction i =>
Size -> (Size -> FromFunctionPixel i) -> i
fromFunction (forall i. MaskedImage i => i -> Size
shape src
img) (ImagePixel src -> ImagePixel (Manifest p)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (src
img forall i. Image i => i -> Size -> ImagePixel i
!))
    {-# INLINE map #-}

-- Delayed images --------------------------------------------------------------

-- | A delayed image is an image which is constructed using a function.
--
-- Usually, a delayed image maps each of its pixels over another image.
-- Delayed images are useful by avoiding intermediate images in a
-- transformation pipeline of images or by avoiding the computation of the whole
-- resulting image when only a portion of its pixels will be accessed.
data Delayed p = Delayed {
      forall p. Delayed p -> Size
delayedSize :: !Size
    , forall p. Delayed p -> Size -> p
delayedFun  :: !(Point -> p)
    }

instance Storable p => MaskedImage (Delayed p) where
    type ImagePixel (Delayed p) = p

    shape :: Delayed p -> Size
shape = forall p. Delayed p -> Size
delayedSize
    {-# INLINE shape #-}

    maskedIndex :: Delayed p -> Size -> Maybe (ImagePixel (Delayed p))
maskedIndex Delayed p
img = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. Delayed p -> Size -> p
delayedFun Delayed p
img
    {-# INLINE maskedIndex #-}

instance Storable p => Image (Delayed p) where
    index :: Delayed p -> Size -> ImagePixel (Delayed p)
index = forall p. Delayed p -> Size -> p
delayedFun
    {-# INLINE index #-}

instance FromFunction (Delayed p) where
    type FromFunctionPixel (Delayed p) = p

    fromFunction :: Size -> (Size -> FromFunctionPixel (Delayed p)) -> Delayed p
fromFunction = forall p. Size -> (Size -> p) -> Delayed p
Delayed
    {-# INLINE fromFunction #-}

instance (Image src, Storable p) => FunctorImage src (Delayed p) where
    map :: (ImagePixel src -> ImagePixel (Delayed p)) -> src -> Delayed p
map ImagePixel src -> ImagePixel (Delayed p)
f src
img = forall i.
FromFunction i =>
Size -> (Size -> FromFunctionPixel i) -> i
fromFunction (forall i. MaskedImage i => i -> Size
shape src
img) (ImagePixel src -> ImagePixel (Delayed p)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (src
img forall i. Image i => i -> Size -> ImagePixel i
!))
    {-# INLINE map #-}

-- Masked delayed images -------------------------------------------------------

data DelayedMask p = DelayedMask {
      forall p. DelayedMask p -> Size
delayedMaskSize :: !Size
    , forall p. DelayedMask p -> Size -> Maybe p
delayedMaskFun  :: !(Point -> Maybe p)
    }

instance Storable p => MaskedImage (DelayedMask p) where
    type ImagePixel (DelayedMask p) = p

    shape :: DelayedMask p -> Size
shape = forall p. DelayedMask p -> Size
delayedMaskSize
    {-# INLINE shape #-}

    maskedIndex :: DelayedMask p -> Size -> Maybe (ImagePixel (DelayedMask p))
maskedIndex = forall p. DelayedMask p -> Size -> Maybe p
delayedMaskFun
    {-# INLINE maskedIndex #-}

instance Storable p => FromFunction (DelayedMask p) where
    type FromFunctionPixel (DelayedMask p) = Maybe p

    fromFunction :: Size
-> (Size -> FromFunctionPixel (DelayedMask p)) -> DelayedMask p
fromFunction = forall p. Size -> (Size -> Maybe p) -> DelayedMask p
DelayedMask
    {-# INLINE fromFunction #-}

instance (MaskedImage src, Storable p) => FunctorImage src (DelayedMask p) where
    map :: (ImagePixel src -> ImagePixel (DelayedMask p))
-> src -> DelayedMask p
map ImagePixel src -> ImagePixel (DelayedMask p)
f src
img = forall i.
FromFunction i =>
Size -> (Size -> FromFunctionPixel i) -> i
fromFunction (forall i. MaskedImage i => i -> Size
shape src
img) (\Size
pt -> ImagePixel src -> ImagePixel (DelayedMask p)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (src
img forall i. MaskedImage i => i -> Size -> Maybe (ImagePixel i)
`maskedIndex` Size
pt))
    {-# INLINE map #-}


-- Conversion and type helpers -------------------------------------------------

-- | Delays an image in its delayed representation.
delay :: Image i => i -> Delayed (ImagePixel i)
delay :: forall i. Image i => i -> Delayed (ImagePixel i)
delay = forall src res.
FunctorImage src res =>
(ImagePixel src -> ImagePixel res) -> src -> res
map forall a. a -> a
id
{-# INLINE delay #-}

-- | Computes the value of an image into a manifest representation.
compute :: (Image i, Storable (ImagePixel i)) => i -> Manifest (ImagePixel i)
compute :: forall i.
(Image i, Storable (ImagePixel i)) =>
i -> Manifest (ImagePixel i)
compute = forall src res.
FunctorImage src res =>
(ImagePixel src -> ImagePixel res) -> src -> res
map forall a. a -> a
id
{-# INLINE compute #-}

instance (Storable p1, Storable p2, Convertible p1 p2)
    => Convertible (Manifest p1) (Manifest p2) where
    safeConvert :: Manifest p1 -> ConvertResult (Manifest p2)
safeConvert = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall src res.
FunctorImage src res =>
(ImagePixel src -> ImagePixel res) -> src -> res
map forall a b. Convertible a b => a -> b
convert
    {-# INLINE safeConvert #-}

instance (Storable p1, Storable p2, Convertible p1 p2)
    => Convertible (Delayed p1) (Delayed p2) where
    safeConvert :: Delayed p1 -> ConvertResult (Delayed p2)
safeConvert = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall src res.
FunctorImage src res =>
(ImagePixel src -> ImagePixel res) -> src -> res
map forall a b. Convertible a b => a -> b
convert
    {-# INLINE safeConvert #-}

instance (Storable p1, Storable p2, Convertible p1 p2)
    => Convertible (Delayed p1) (Manifest p2) where
    safeConvert :: Delayed p1 -> ConvertResult (Manifest p2)
safeConvert = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall src res.
FunctorImage src res =>
(ImagePixel src -> ImagePixel res) -> src -> res
map forall a b. Convertible a b => a -> b
convert
    {-# INLINE safeConvert #-}

instance (Storable p1, Storable p2, Convertible p1 p2)
    => Convertible (Manifest p1) (Delayed  p2) where
    safeConvert :: Manifest p1 -> ConvertResult (Delayed p2)
safeConvert = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall src res.
FunctorImage src res =>
(ImagePixel src -> ImagePixel res) -> src -> res
map forall a b. Convertible a b => a -> b
convert
    {-# INLINE safeConvert #-}

-- | Forces an image to be in its delayed representation. Does nothing.
delayed :: Delayed p -> Delayed p
delayed :: forall p. Delayed p -> Delayed p
delayed = forall a. a -> a
id

-- | Forces an image to be in its manifest representation. Does nothing.
manifest :: Manifest p -> Manifest p
manifest :: forall p. Manifest p -> Manifest p
manifest = forall a. a -> a
id