module Graphics.Image.Interface (
ColorSpace(..), Alpha(..), Elevator(..),
Array(..), ManifestArray(..), SequentialArray(..), MutableArray(..),
Exchangable(..),
defaultIndex, maybeIndex, Border(..), borderIndex
) where
import Prelude hiding (and, map, zipWith, sum, product)
import GHC.Exts (Constraint)
import Data.Typeable (Typeable, showsTypeRep, typeOf)
import Data.Monoid (Monoid)
import Control.DeepSeq (NFData(rnf))
import Data.Word
import Data.Foldable (Foldable(foldMap))
import Control.Applicative
import Control.Monad.Primitive (PrimMonad (..))
class (Eq cs, Enum cs, Show cs, Typeable cs) => ColorSpace cs where
type PixelElt cs e
data Pixel cs e
fromChannel :: e -> Pixel cs e
toElt :: Pixel cs e -> PixelElt cs e
fromElt :: PixelElt cs e -> Pixel cs e
getPxCh :: Pixel cs e -> cs -> e
chOp :: (cs -> e' -> e) -> Pixel cs e' -> Pixel cs e
pxOp :: (e' -> e) -> Pixel cs e' -> Pixel cs e
chApp :: Pixel cs (e' -> e) -> Pixel cs e' -> Pixel cs e
pxFoldMap :: Monoid m => (e -> m) -> Pixel cs e -> m
class (ColorSpace (Opaque cs), ColorSpace cs) => Alpha cs where
type Opaque cs
getAlpha :: Pixel cs e -> e
addAlpha :: e -> Pixel (Opaque cs) e -> Pixel cs e
dropAlpha :: Pixel cs e -> Pixel (Opaque cs) e
class Elevator e where
toWord8 :: ColorSpace cs => Pixel cs e -> Pixel cs Word8
toWord16 :: ColorSpace cs => Pixel cs e -> Pixel cs Word16
toWord32 :: ColorSpace cs => Pixel cs e -> Pixel cs Word32
toWord64 :: ColorSpace cs => Pixel cs e -> Pixel cs Word64
toFloat :: ColorSpace cs => Pixel cs e -> Pixel cs Float
toDouble :: ColorSpace cs => Pixel cs e -> Pixel cs Double
fromDouble :: ColorSpace cs => Pixel cs Double -> Pixel cs e
class (Show arr, ColorSpace cs, Num (Pixel cs e), Num e, Typeable e, Elt arr cs e) =>
Array arr cs e where
type Elt arr cs e :: Constraint
type Elt arr cs e = ()
data Image arr cs e
make :: (Int, Int)
-> ((Int, Int) -> Pixel cs e)
-> Image arr cs e
singleton :: Pixel cs e -> Image arr cs e
dims :: Image arr cs e -> (Int, Int)
map :: Array arr cs' e' =>
(Pixel cs' e' -> Pixel cs e)
-> Image arr cs' e'
-> Image arr cs e
imap :: Array arr cs' e' =>
((Int, Int) -> Pixel cs' e' -> Pixel cs e)
-> Image arr cs' e'
-> Image arr cs e
zipWith :: (Array arr cs1 e1, Array arr cs2 e2) =>
(Pixel cs1 e1 -> Pixel cs2 e2 -> Pixel cs e)
-> Image arr cs1 e1 -> Image arr cs2 e2 -> Image arr cs e
izipWith :: (Array arr cs1 e1, Array arr cs2 e2) =>
((Int, Int) -> Pixel cs1 e1 -> Pixel cs2 e2 -> Pixel cs e)
-> Image arr cs1 e1 -> Image arr cs2 e2 -> Image arr cs e
traverse :: Array arr cs' e' =>
Image arr cs' e'
-> ((Int, Int) -> (Int, Int))
-> (((Int, Int) -> Pixel cs' e') ->
(Int, Int) -> Pixel cs e)
-> Image arr cs e
traverse2 :: (Array arr cs1 e1, Array arr cs2 e2) =>
Image arr cs1 e1
-> Image arr cs2 e2
-> ((Int, Int) -> (Int, Int) -> (Int, Int))
-> (((Int, Int) -> Pixel cs1 e1) ->
((Int, Int) -> Pixel cs2 e2) ->
(Int, Int) -> Pixel cs e)
-> Image arr cs e
transpose :: Image arr cs e -> Image arr cs e
backpermute :: (Int, Int)
-> ((Int, Int) -> (Int, Int))
-> Image arr cs e
-> Image arr cs e
fromLists :: [[Pixel cs e]]
-> Image arr cs e
class Array arr cs e => ManifestArray arr cs e where
index :: Image arr cs e -> (Int, Int) -> Pixel cs e
deepSeqImage :: Image arr cs e -> a -> a
(|*|) :: Image arr cs e -> Image arr cs e -> Image arr cs e
fold :: (Pixel cs e -> Pixel cs e -> Pixel cs e)
-> Pixel cs e
-> Image arr cs e
-> Pixel cs e
eq :: Eq (Pixel cs e) => Image arr cs e -> Image arr cs e -> Bool
class ManifestArray arr cs e => SequentialArray arr cs e where
foldl :: (a -> Pixel cs e -> a) -> a -> Image arr cs e -> a
foldr :: (Pixel cs e -> a -> a) -> a -> Image arr cs e -> a
mapM :: (Array arr cs' e', Monad m) =>
(Pixel cs' e' -> m (Pixel cs e)) -> Image arr cs' e' -> m (Image arr cs e)
mapM_ :: (Array arr cs' e', Monad m) =>
(Pixel cs' e' -> m (Pixel cs e)) -> Image arr cs' e' -> m ()
foldM :: Monad m => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m a
foldM_ :: Monad m => (a -> Pixel cs e -> m a) -> a -> Image arr cs e -> m ()
class ManifestArray arr cs e => MutableArray arr cs e where
data MImage st arr cs e
mdims :: MImage st arr cs e -> (Int, Int)
thaw :: PrimMonad m => Image arr cs e -> m (MImage (PrimState m) arr cs e)
freeze :: PrimMonad m => MImage (PrimState m) arr cs e -> m (Image arr cs e)
new :: PrimMonad m => (Int, Int) -> m (MImage (PrimState m) arr cs e)
read :: PrimMonad m => MImage (PrimState m) arr cs e -> (Int, Int) -> m (Pixel cs e)
write :: PrimMonad m => MImage (PrimState m) arr cs e -> (Int, Int) -> Pixel cs e -> m ()
swap :: PrimMonad m => MImage (PrimState m) arr cs e -> (Int, Int) -> (Int, Int) -> m ()
class Exchangable arr' arr where
exchange :: (Array arr' cs e, Array arr cs e) =>
arr
-> Image arr' cs e
-> Image arr cs e
instance Exchangable arr arr where
exchange _ = id
data Border px =
Fill !px
| Wrap
| Edge
| Reflect
| Continue
borderIndex :: Border (Pixel cs e)
-> (Int, Int)
-> ((Int, Int) -> Pixel cs e)
-> (Int, Int)
-> Pixel cs e
borderIndex border !(m, n) !getPx !(i, j) =
if i >= 0 && j >= 0 && i < m && j < n then getPx (i, j) else getPxB border where
getPxB (Fill px) = px
getPxB Wrap = getPx (i `mod` m, j `mod` n)
getPxB Edge = getPx (if i < 0 then 0 else if i >= m then m 1 else i,
if j < 0 then 0 else if j >= n then n 1 else j)
getPxB Reflect = getPx (if i < 0 then (abs i 1) `mod` m else
if i >= m then (m (i m + 1)) `mod` m else i,
if j < 0 then (abs j 1) `mod` n else
if j >= n then (n (j n + 1)) `mod` n else j)
getPxB Continue = getPx (if i < 0 then abs i `mod` m else
if i >= m then m (i m + 2) `mod` m else i,
if j < 0 then abs j `mod` n else
if j >= n then n (j n + 2) `mod` n else j)
defaultIndex :: ManifestArray arr cs e =>
Pixel cs e -> Image arr cs e -> (Int, Int) -> Pixel cs e
defaultIndex !px !img = borderIndex (Fill px) (dims img) (index img)
maybeIndex :: ManifestArray arr cs e =>
Image arr cs e -> (Int, Int) -> Maybe (Pixel cs e)
maybeIndex !img@(dims -> (m, n)) !(i, j) =
if i >= 0 && j >= 0 && i < m && j < n then Just $ index img (i, j) else Nothing
instance ColorSpace cs => Functor (Pixel cs) where
fmap = pxOp
instance ColorSpace cs => Applicative (Pixel cs) where
pure = fromChannel
(<*>) = chApp
instance ColorSpace cs => Foldable (Pixel cs) where
foldMap = pxFoldMap
instance (ColorSpace cs, Num e) => Num (Pixel cs e) where
(+) = liftA2 (+)
() = liftA2 ()
(*) = liftA2 (*)
abs = liftA abs
signum = liftA signum
fromInteger = pure . fromInteger
instance (ColorSpace cs, Fractional e) => Fractional (Pixel cs e) where
(/) = liftA2 (/)
recip = liftA recip
fromRational = pure . fromRational
instance (ColorSpace cs, Floating e) => Floating (Pixel cs e) where
pi = fromChannel pi
exp = liftA exp
log = liftA log
sin = liftA sin
cos = liftA cos
asin = liftA asin
atan = liftA atan
acos = liftA acos
sinh = liftA sinh
cosh = liftA cosh
asinh = liftA asinh
atanh = liftA atanh
acosh = liftA acosh
instance (ManifestArray arr cs e, Eq (Pixel cs e)) => Eq (Image arr cs e) where
(==) = eq
instance Array arr cs e => Num (Image arr cs e) where
(+) = zipWith (+)
() = zipWith ()
(*) = zipWith (*)
abs = map abs
signum = map signum
fromInteger = singleton . fromInteger
instance (Fractional (Pixel cs e), Fractional e, Array arr cs e) =>
Fractional (Image arr cs e) where
(/) = zipWith (/)
fromRational = singleton . fromRational
instance (Floating (Pixel cs e), Floating e, Array arr cs e) =>
Floating (Image arr cs e) where
pi = singleton pi
exp = map exp
log = map log
sin = map sin
cos = map cos
asin = map asin
atan = map atan
acos = map acos
sinh = map sinh
cosh = map cosh
asinh = map asinh
atanh = map atanh
acosh = map acosh
instance ManifestArray arr cs e => NFData (Image arr cs e) where
rnf img = img `deepSeqImage` ()
instance Array arr cs e => Show (Image arr cs e) where
show ((dims -> (m, n)) :: Image arr cs e) =
"<Image "++show (undefined :: arr)++" "++
((showsTypeRep (typeOf (undefined :: cs))) " (")++
((showsTypeRep (typeOf (undefined :: e))) "): "++show m++"x"++show n++">")
instance MutableArray arr cs e => Show (MImage st arr cs e) where
show ((mdims -> (m, n)) :: MImage st arr cs e) =
"<MutableImage "++show (undefined :: arr)++" "++
((showsTypeRep (typeOf (undefined :: cs))) " (")++
((showsTypeRep (typeOf (undefined :: e))) "): "++show m++"x"++show n++">")