module Graphics.Rasterific.Compositor
( Compositor
, Modulable( .. )
, InterpolablePixel( .. )
, maxDistance
, RenderablePixel
, ModulablePixel
, compositionDestination
, compositionAlpha
, emptyPx
) where
import Foreign.Storable( Storable )
import Data.Bits( unsafeShiftR )
import Data.Word( Word8, Word32 )
import Codec.Picture.Types
( Pixel( .. )
, PixelRGB8( .. )
, PixelRGBA8( .. )
, PackeablePixel( .. ) )
import Graphics.Rasterific.Linear
import Graphics.Rasterific.Types
type Compositor px =
PixelBaseComponent px ->
PixelBaseComponent px -> px -> px -> px
class ( Applicative (Holder a)
, Functor (Holder a)
, Foldable (Holder a)
, Additive (Holder a) ) => InterpolablePixel a where
type Holder a :: * -> *
toFloatPixel :: a -> Holder a Float
fromFloatPixel :: Holder a Float -> a
maxRepresentable :: Proxy a -> Float
maxDistance :: InterpolablePixel a => a -> a -> Float
maxDistance p1 p2 = maximum $ abs <$> (toFloatPixel p1 ^-^ toFloatPixel p2)
instance InterpolablePixel Float where
type Holder Float = V1
toFloatPixel = V1
fromFloatPixel (V1 f) = f
maxRepresentable Proxy = 1
instance InterpolablePixel Word8 where
type Holder Word8 = V1
toFloatPixel = V1 . fromIntegral
fromFloatPixel (V1 f) = floor f
maxRepresentable Proxy = 255
instance InterpolablePixel PixelRGB8 where
type Holder PixelRGB8 = V3
toFloatPixel (PixelRGB8 r g b) = V3 (to r) (to g) (to b) where to n = fromIntegral n
fromFloatPixel (V3 r g b) = PixelRGB8 (to r) (to g) (to b) where to = floor
maxRepresentable Proxy = 255
instance InterpolablePixel PixelRGBA8 where
type Holder PixelRGBA8 = V4
toFloatPixel (PixelRGBA8 r g b a) = V4 (to r) (to g) (to b) (to a)
where to n = fromIntegral n
fromFloatPixel (V4 r g b a) = PixelRGBA8 (to r) (to g) (to b) (to a)
where to = floor
maxRepresentable Proxy = 255
type ModulablePixel px =
( Pixel px
, PackeablePixel px
, InterpolablePixel px
, InterpolablePixel (PixelBaseComponent px)
, Storable (PackedRepresentation px)
, Modulable (PixelBaseComponent px))
type RenderablePixel px =
( ModulablePixel px
, Pixel (PixelBaseComponent px)
, PackeablePixel (PixelBaseComponent px)
, Num (PackedRepresentation px)
, Num (PackedRepresentation (PixelBaseComponent px))
, Num (Holder px Float)
, Num (Holder (PixelBaseComponent px) Float)
, Storable (PackedRepresentation (PixelBaseComponent px))
, PixelBaseComponent (PixelBaseComponent px)
~ (PixelBaseComponent px)
)
class (Ord a, Num a) => Modulable a where
emptyValue :: a
fullValue :: a
clampCoverage :: Float -> (a, a)
modulate :: a -> a -> a
modiv :: a -> a -> a
alphaOver :: a
-> a
-> a
-> a
-> a
alphaCompose :: a -> a -> a -> a -> a
coverageModulate :: a -> a -> (a, a)
coverageModulate c a = (clamped, fullValue clamped)
where clamped = modulate a c
instance Modulable Float where
emptyValue = 0
fullValue = 1
clampCoverage f = (f, 1 f)
modulate = (*)
modiv = (/)
alphaCompose coverage inverseCoverage backAlpha _ =
coverage + backAlpha * inverseCoverage
alphaOver coverage inverseCoverage background painted =
coverage * painted + background * inverseCoverage
div255 :: Word32 -> Word32
div255 v = (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8
instance Modulable Word8 where
emptyValue = 0
fullValue = 255
clampCoverage f = (fromIntegral c, fromIntegral $ 255 c)
where c = toWord8 f
modulate c a = fromIntegral . div255 $ fi c * fi a + 128
where fi :: Word8 -> Word32
fi = fromIntegral
modiv c 0 = c
modiv c a = fromIntegral . min 255 $ (fi c * 255) `div` fi a
where fi :: Word8 -> Word32
fi = fromIntegral
alphaCompose coverage inverseCoverage backgroundAlpha _ =
fromIntegral $ div255 v
where fi :: Word8 -> Word32
fi = fromIntegral
v = fi coverage * 255
+ fi backgroundAlpha * fi inverseCoverage + 128
alphaOver coverage inverseCoverage background painted =
fromIntegral $ div255 v
where fi :: Word8 -> Word32
fi = fromIntegral
v = fi coverage * fi painted + fi background * fi inverseCoverage + 128
toWord8 :: Float -> Int
toWord8 r = floor $ r * 255 + 0.5
compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px))
=> Compositor px
compositionDestination c _ _ = colorMap (modulate c)
compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px))
=> Compositor px
compositionAlpha c ic
| c == emptyValue = const
| c == fullValue = \_ n -> n
| otherwise = \bottom top ->
let bottomOpacity = pixelOpacity bottom
alphaOut = alphaCompose c ic bottomOpacity (pixelOpacity top)
colorComposer _ back fore =
alphaOver c ic (back `modulate` bottomOpacity) fore
`modiv` alphaOut
in
mixWithAlpha colorComposer (\_ _ -> alphaOut) bottom top
emptyPx :: (RenderablePixel px) => px
emptyPx = colorMap (const emptyValue) $ unpackPixel 0