{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Graphics.Pixel.Internal -- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental -- Portability : non-portable -- module Graphics.Pixel.Internal ( Pixel(..) , liftPixel , toPixel8 , toPixel16 , toPixel32 , toPixel64 , toPixelF , toPixelD ) where import Data.Coerce import Control.DeepSeq (NFData) import Graphics.Color.Model.Internal import Control.Monad (liftM) import Foreign.Storable import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as VM import qualified Data.Vector.Unboxed as VU -- | Digital imaging is one of the most common places for a color to be used in. The -- smallest element in any image is a pixel, which is defined by its color. -- -- @since 0.1.0 newtype Pixel cs e = Pixel { pixelColor :: Color cs e } deriving instance Eq (Color cs e) => Eq (Pixel cs e) deriving instance Ord (Color cs e) => Ord (Pixel cs e) deriving instance Num (Color cs e) => Num (Pixel cs e) deriving instance Bounded (Color cs e) => Bounded (Pixel cs e) deriving instance NFData (Color cs e) => NFData (Pixel cs e) deriving instance Floating (Color cs e) => Floating (Pixel cs e) deriving instance Fractional (Color cs e) => Fractional (Pixel cs e) deriving instance Functor (Color cs) => Functor (Pixel cs) deriving instance Applicative (Color cs) => Applicative (Pixel cs) deriving instance Foldable (Color cs) => Foldable (Pixel cs) deriving instance Traversable (Color cs) => Traversable (Pixel cs) deriving instance Storable (Color cs e) => Storable (Pixel cs e) instance Show (Color cs e) => Show (Pixel cs e) where show = show . pixelColor -- | Unboxing of a `Pixel`. instance ColorModel cs e => VU.Unbox (Pixel cs e) newtype instance VU.MVector s (Pixel cs e) = MV_Pixel (VU.MVector s (Components cs e)) instance ColorModel cs e => VM.MVector VU.MVector (Pixel cs e) where basicLength (MV_Pixel mvec) = VM.basicLength mvec {-# INLINE basicLength #-} basicUnsafeSlice idx len (MV_Pixel mvec) = MV_Pixel (VM.basicUnsafeSlice idx len mvec) {-# INLINE basicUnsafeSlice #-} basicOverlaps (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicOverlaps mvec mvec' {-# INLINE basicOverlaps #-} basicUnsafeNew len = MV_Pixel `liftM` VM.basicUnsafeNew len {-# INLINE basicUnsafeNew #-} basicUnsafeReplicate len val = MV_Pixel `liftM` VM.basicUnsafeReplicate len (toComponents (coerce val)) {-# INLINE basicUnsafeReplicate #-} basicUnsafeRead (MV_Pixel mvec) idx = (coerce . fromComponents) `liftM` VM.basicUnsafeRead mvec idx {-# INLINE basicUnsafeRead #-} basicUnsafeWrite (MV_Pixel mvec) idx val = VM.basicUnsafeWrite mvec idx (toComponents (coerce val)) {-# INLINE basicUnsafeWrite #-} basicClear (MV_Pixel mvec) = VM.basicClear mvec {-# INLINE basicClear #-} basicSet (MV_Pixel mvec) val = VM.basicSet mvec (toComponents (coerce val)) {-# INLINE basicSet #-} basicUnsafeCopy (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicUnsafeCopy mvec mvec' {-# INLINE basicUnsafeCopy #-} basicUnsafeMove (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicUnsafeMove mvec mvec' {-# INLINE basicUnsafeMove #-} basicUnsafeGrow (MV_Pixel mvec) len = MV_Pixel `liftM` VM.basicUnsafeGrow mvec len {-# INLINE basicUnsafeGrow #-} #if MIN_VERSION_vector(0,11,0) basicInitialize (MV_Pixel mvec) = VM.basicInitialize mvec {-# INLINE basicInitialize #-} #endif newtype instance VU.Vector (Pixel cs e) = V_Pixel (VU.Vector (Components cs e)) instance (ColorModel cs e) => V.Vector VU.Vector (Pixel cs e) where basicUnsafeFreeze (MV_Pixel mvec) = V_Pixel `liftM` V.basicUnsafeFreeze mvec {-# INLINE basicUnsafeFreeze #-} basicUnsafeThaw (V_Pixel vec) = MV_Pixel `liftM` V.basicUnsafeThaw vec {-# INLINE basicUnsafeThaw #-} basicLength (V_Pixel vec) = V.basicLength vec {-# INLINE basicLength #-} basicUnsafeSlice idx len (V_Pixel vec) = V_Pixel (V.basicUnsafeSlice idx len vec) {-# INLINE basicUnsafeSlice #-} basicUnsafeIndexM (V_Pixel vec) idx = (coerce . fromComponents) `liftM` V.basicUnsafeIndexM vec idx {-# INLINE basicUnsafeIndexM #-} basicUnsafeCopy (MV_Pixel mvec) (V_Pixel vec) = V.basicUnsafeCopy mvec vec {-# INLINE basicUnsafeCopy #-} elemseq (V_Pixel vec) val = V.elemseq vec (toComponents (coerce val)) {-# INLINE elemseq #-} -- | Apply a function to `Pixel`'s `Color` -- -- @since 0.1.0 liftPixel :: (Color cs e -> Color cs' e') -> Pixel cs e -> Pixel cs' e' liftPixel f = coerce . f . coerce {-# INLINE liftPixel #-} -- Elevation -- | Convert all channels of a pixel to 8bits each, while doing appropriate scaling. See -- `Elevator`. -- -- @since 0.1.0 toPixel8 :: ColorModel cs e => Pixel cs e -> Pixel cs Word8 toPixel8 = liftPixel (fmap toWord8) {-# INLINE toPixel8 #-} -- | Convert all channels of a pixel to 16bits each, while appropriate scaling. See -- `Elevator`. -- -- @since 0.1.0 toPixel16 :: ColorModel cs e => Pixel cs e -> Pixel cs Word16 toPixel16 = liftPixel (fmap toWord16) {-# INLINE toPixel16 #-} -- | Convert all channels of a pixel to 32bits each, while doing appropriate scaling. See -- `Elevator`. -- -- @since 0.1.0 toPixel32 :: ColorModel cs e => Pixel cs e -> Pixel cs Word32 toPixel32 = liftPixel (fmap toWord32) {-# INLINE toPixel32 #-} -- | Convert all channels of a pixel to 64bits each, while doing appropriate scaling. See -- `Elevator`. -- -- @since 0.1.0 toPixel64 :: ColorModel cs e => Pixel cs e -> Pixel cs Word64 toPixel64 = liftPixel (fmap toWord64) {-# INLINE toPixel64 #-} -- | Convert all channels of a pixel to 32bit floating point numers each, while doing -- appropriate scaling. See `Elevator`. -- -- @since 0.1.0 toPixelF :: ColorModel cs e => Pixel cs e -> Pixel cs Float toPixelF = liftPixel (fmap toFloat) {-# INLINE toPixelF #-} -- | Convert all channels of a pixel to 64bit floating point numers each, while doing -- appropriate scaling. See `Elevator`. -- -- @since 0.1.0 toPixelD :: ColorModel cs e => Pixel cs e -> Pixel cs Double toPixelD = liftPixel (fmap toDouble) {-# INLINE toPixelD #-}