module Graphics.Image.ColorSpace.HSI (
HSI(..), HSIA(..), Pixel(..),
ToHSI(..), ToHSIA(..)
) where
import Prelude hiding (map)
import Control.Applicative
import Data.Foldable
import Data.Typeable (Typeable)
import Foreign.Ptr
import Foreign.Storable
import Graphics.Image.Interface
data HSI = HueHSI
| SatHSI
| IntHSI
deriving (Eq, Enum, Typeable)
data instance Pixel HSI e = PixelHSI !e !e !e deriving Eq
instance Show HSI where
show HueHSI = "Hue"
show SatHSI = "Saturation"
show IntHSI = "Intensity"
instance Show e => Show (Pixel HSI e) where
show (PixelHSI h s i) = "<HSI:("++show h++"|"++show s++"|"++show i++")>"
instance (Elevator e, Typeable e) => ColorSpace HSI e where
type Components HSI e = (e, e, e)
toComponents (PixelHSI h s i) = (h, s, i)
fromComponents !(h, s, i) = PixelHSI h s i
broadcastC = pure
getPxC (PixelHSI h _ _) HueHSI = h
getPxC (PixelHSI _ s _) SatHSI = s
getPxC (PixelHSI _ _ i) IntHSI = i
setPxC (PixelHSI _ s i) HueHSI h = PixelHSI h s i
setPxC (PixelHSI h _ i) SatHSI s = PixelHSI h s i
setPxC (PixelHSI h s _) IntHSI i = PixelHSI h s i
mapPxC f (PixelHSI h s i) = PixelHSI (f HueHSI h) (f SatHSI s) (f IntHSI i)
mapPx = fmap
zipWithPx = liftA2
foldlPx = foldl'
instance Functor (Pixel HSI) where
fmap f (PixelHSI h s i) = PixelHSI (f h) (f s) (f i)
instance Applicative (Pixel HSI) where
pure !e = PixelHSI e e e
(PixelHSI fh fs fi) <*> (PixelHSI h s i) = PixelHSI (fh h) (fs s) (fi i)
instance Foldable (Pixel HSI) where
foldr f !z (PixelHSI h s i) = f h (f s (f i z))
instance Num e => Num (Pixel HSI e) where
(+) = liftA2 (+)
() = liftA2 ()
(*) = liftA2 (*)
abs = liftA abs
signum = liftA signum
fromInteger = pure . fromInteger
instance Fractional e => Fractional (Pixel HSI e) where
(/) = liftA2 (/)
recip = liftA recip
fromRational = pure . fromRational
instance Floating e => Floating (Pixel HSI e) where
pi = pure 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 Storable e => Storable (Pixel HSI e) where
sizeOf _ = 3 * sizeOf (undefined :: e)
alignment _ = alignment (undefined :: e)
peek p = do
q <- return $ castPtr p
r <- peek q
g <- peekElemOff q 1
b <- peekElemOff q 2
return (PixelHSI r g b)
poke p (PixelHSI r g b) = do
q <- return $ castPtr p
poke q r
pokeElemOff q 1 g
pokeElemOff q 2 b
data HSIA = HueHSIA
| SatHSIA
| IntHSIA
| AlphaHSIA
deriving (Eq, Enum, Typeable)
data instance Pixel HSIA e = PixelHSIA !e !e !e !e deriving Eq
class ColorSpace cs Double => ToHSI cs where
toPixelHSI :: Pixel cs Double -> Pixel HSI Double
toImageHSI :: (Array arr cs Double, Array arr HSI Double) =>
Image arr cs Double
-> Image arr HSI Double
toImageHSI = map toPixelHSI
instance Show HSIA where
show HueHSIA = "Hue"
show SatHSIA = "Saturation"
show IntHSIA = "Intensity"
show AlphaHSIA = "Alpha"
instance Show e => Show (Pixel HSIA e) where
show (PixelHSIA h s i a) = "<HSIA:("++show h++"|"++show s++"|"++show i++"|"++show a++")>"
instance (Elevator e, Typeable e) => ColorSpace HSIA e where
type Components HSIA e = (e, e, e, e)
toComponents (PixelHSIA h s i a) = (h, s, i, a)
fromComponents !(h, s, i, a) = PixelHSIA h s i a
broadcastC = pure
getPxC (PixelHSIA h _ _ _) HueHSIA = h
getPxC (PixelHSIA _ s _ _) SatHSIA = s
getPxC (PixelHSIA _ _ i _) IntHSIA = i
getPxC (PixelHSIA _ _ _ a) AlphaHSIA = a
setPxC (PixelHSIA _ s i a) HueHSIA h = PixelHSIA h s i a
setPxC (PixelHSIA h _ i a) SatHSIA s = PixelHSIA h s i a
setPxC (PixelHSIA h s _ a) IntHSIA i = PixelHSIA h s i a
setPxC (PixelHSIA h s i _) AlphaHSIA a = PixelHSIA h s i a
mapPxC f (PixelHSIA h s i a) =
PixelHSIA (f HueHSIA h) (f SatHSIA s) (f IntHSIA i) (f AlphaHSIA a)
mapPx = fmap
zipWithPx = liftA2
foldlPx = foldl'
instance (Elevator e, Typeable e) => AlphaSpace HSIA e where
type Opaque HSIA = HSI
getAlpha (PixelHSIA _ _ _ a) = a
addAlpha !a (PixelHSI h s i) = PixelHSIA h s i a
dropAlpha (PixelHSIA h s i _) = PixelHSI h s i
class (ToHSI (Opaque cs), AlphaSpace cs Double) => ToHSIA cs where
toPixelHSIA :: Pixel cs Double -> Pixel HSIA Double
toPixelHSIA px = addAlpha (getAlpha px) (toPixelHSI (dropAlpha px))
toImageHSIA :: (Array arr cs Double, Array arr HSIA Double) =>
Image arr cs Double
-> Image arr HSIA Double
toImageHSIA = map toPixelHSIA
instance Functor (Pixel HSIA) where
fmap f (PixelHSIA h s i a) = PixelHSIA (f h) (f s) (f i) (f a)
instance Applicative (Pixel HSIA) where
pure !e = PixelHSIA e e e e
(PixelHSIA fh fs fi fa) <*> (PixelHSIA h s i a) = PixelHSIA (fh h) (fs s) (fi i) (fa a)
instance Foldable (Pixel HSIA) where
foldr f !z (PixelHSIA h s i a) = f h (f s (f i (f a z)))
instance Num e => Num (Pixel HSIA e) where
(+) = liftA2 (+)
() = liftA2 ()
(*) = liftA2 (*)
abs = liftA abs
signum = liftA signum
fromInteger = pure . fromInteger
instance Fractional e => Fractional (Pixel HSIA e) where
(/) = liftA2 (/)
recip = liftA recip
fromRational = pure . fromRational
instance Floating e => Floating (Pixel HSIA e) where
pi = pure 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 Storable e => Storable (Pixel HSIA e) where
sizeOf _ = 3 * sizeOf (undefined :: e)
alignment _ = alignment (undefined :: e)
peek p = do
q <- return $ castPtr p
h <- peek q
s <- peekElemOff q 1
i <- peekElemOff q 2
a <- peekElemOff q 3
return (PixelHSIA h s i a)
poke p (PixelHSIA h s i a) = do
q <- return $ castPtr p
poke q h
pokeElemOff q 1 s
pokeElemOff q 2 i
pokeElemOff q 3 a