{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
module Graphics.Rasterific.Compositor
( Compositor
, Modulable( .. )
, InterpolablePixel( .. )
, maxDistance
, RenderablePixel
, ModulablePixel
, compositionDestination
, compositionAlpha
, emptyPx
) where
import Data.Kind ( Type )
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 :: Type -> Type
toFloatPixel :: a -> Holder a Float
fromFloatPixel :: Holder a Float -> a
maxRepresentable :: Proxy a -> Float
maxDistance :: InterpolablePixel a => a -> a -> Float
maxDistance :: a -> a -> Float
maxDistance a
p1 a
p2 = Holder a Float -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Holder a Float -> Float) -> Holder a Float -> Float
forall a b. (a -> b) -> a -> b
$ Float -> Float
forall a. Num a => a -> a
abs (Float -> Float) -> Holder a Float -> Holder a Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> Holder a Float
forall a. InterpolablePixel a => a -> Holder a Float
toFloatPixel a
p1 Holder a Float -> Holder a Float -> Holder a Float
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ a -> Holder a Float
forall a. InterpolablePixel a => a -> Holder a Float
toFloatPixel a
p2)
instance InterpolablePixel Float where
type Holder Float = V1
toFloatPixel :: Float -> Holder Float Float
toFloatPixel = Float -> Holder Float Float
forall a. a -> V1 a
V1
fromFloatPixel :: Holder Float Float -> Float
fromFloatPixel (V1 f) = Float
f
maxRepresentable :: Proxy Float -> Float
maxRepresentable Proxy Float
Proxy = Float
1
instance InterpolablePixel Word8 where
type Holder Word8 = V1
toFloatPixel :: Word8 -> Holder Word8 Float
toFloatPixel = Float -> V1 Float
forall a. a -> V1 a
V1 (Float -> V1 Float) -> (Word8 -> Float) -> Word8 -> V1 Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral
fromFloatPixel :: Holder Word8 Float -> Word8
fromFloatPixel (V1 f) = Float -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
f
maxRepresentable :: Proxy Word8 -> Float
maxRepresentable Proxy Word8
Proxy = Float
255
instance InterpolablePixel PixelRGB8 where
type Holder PixelRGB8 = V3
toFloatPixel :: PixelRGB8 -> Holder PixelRGB8 Float
toFloatPixel (PixelRGB8 Word8
r Word8
g Word8
b) = Float -> Float -> Float -> V3 Float
forall a. a -> a -> a -> V3 a
V3 (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
to Word8
r) (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
to Word8
g) (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
to Word8
b) where to :: a -> b
to a
n = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n
fromFloatPixel :: Holder PixelRGB8 Float -> PixelRGB8
fromFloatPixel (V3 r g b) = Word8 -> Word8 -> Word8 -> PixelRGB8
PixelRGB8 (Float -> Word8
to Float
r) (Float -> Word8
to Float
g) (Float -> Word8
to Float
b) where to :: Float -> Word8
to = Float -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
floor
maxRepresentable :: Proxy PixelRGB8 -> Float
maxRepresentable Proxy PixelRGB8
Proxy = Float
255
instance InterpolablePixel PixelRGBA8 where
type Holder PixelRGBA8 = V4
toFloatPixel :: PixelRGBA8 -> Holder PixelRGBA8 Float
toFloatPixel (PixelRGBA8 Word8
r Word8
g Word8
b Word8
a) = Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
to Word8
r) (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
to Word8
g) (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
to Word8
b) (Word8 -> Float
forall a b. (Integral a, Num b) => a -> b
to Word8
a)
where to :: a -> b
to a
n = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n
fromFloatPixel :: Holder PixelRGBA8 Float -> PixelRGBA8
fromFloatPixel (V4 r g b a) = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 (Float -> Word8
to Float
r) (Float -> Word8
to Float
g) (Float -> Word8
to Float
b) (Float -> Word8
to Float
a)
where to :: Float -> Word8
to = Float -> Word8
forall a b. (RealFrac a, Integral b) => a -> b
floor
maxRepresentable :: Proxy PixelRGBA8 -> Float
maxRepresentable Proxy PixelRGBA8
Proxy = Float
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)
{-# INLINE coverageModulate #-}
coverageModulate a
c a
a = (a
clamped, a
forall a. Modulable a => a
fullValue a -> a -> a
forall a. Num a => a -> a -> a
- a
clamped)
where clamped :: a
clamped = a -> a -> a
forall a. Modulable a => a -> a -> a
modulate a
a a
c
instance Modulable Float where
emptyValue :: Float
emptyValue = Float
0
fullValue :: Float
fullValue = Float
1
clampCoverage :: Float -> (Float, Float)
clampCoverage Float
f = (Float
f, Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
f)
modulate :: Float -> Float -> Float
modulate = Float -> Float -> Float
forall a. Num a => a -> a -> a
(*)
modiv :: Float -> Float -> Float
modiv = Float -> Float -> Float
forall a. Fractional a => a -> a -> a
(/)
alphaCompose :: Float -> Float -> Float -> Float -> Float
alphaCompose Float
coverage Float
inverseCoverage Float
backAlpha Float
_ =
Float
coverage Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
backAlpha Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
inverseCoverage
alphaOver :: Float -> Float -> Float -> Float -> Float
alphaOver Float
coverage Float
inverseCoverage Float
background Float
painted =
Float
coverage Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
painted Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
background Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
inverseCoverage
div255 :: Word32 -> Word32
{-# INLINE div255 #-}
div255 :: Word32 -> Word32
div255 Word32
v = (Word32
v Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ (Word32
v Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
8)) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
8
instance Modulable Word8 where
{-# INLINE emptyValue #-}
emptyValue :: Word8
emptyValue = Word8
0
{-# INLINE fullValue #-}
fullValue :: Word8
fullValue = Word8
255
{-# INLINE clampCoverage #-}
clampCoverage :: Float -> (Word8, Word8)
clampCoverage Float
f = (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c, Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
255 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c)
where c :: Int
c = Float -> Int
toWord8 Float
f
{-# INLINE modulate #-}
modulate :: Word8 -> Word8 -> Word8
modulate Word8
c Word8
a = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> (Word32 -> Word32) -> Word32 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word32
div255 (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word8 -> Word32
fi Word8
c Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word8 -> Word32
fi Word8
a Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
128
where fi :: Word8 -> Word32
fi :: Word8 -> Word32
fi = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE modiv #-}
modiv :: Word8 -> Word8 -> Word8
modiv Word8
c Word8
0 = Word8
c
modiv Word8
c Word8
a = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> (Word32 -> Word32) -> Word32 -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
min Word32
255 (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ (Word8 -> Word32
fi Word8
c Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
255) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word8 -> Word32
fi Word8
a
where fi :: Word8 -> Word32
fi :: Word8 -> Word32
fi = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE alphaCompose #-}
alphaCompose :: Word8 -> Word8 -> Word8 -> Word8 -> Word8
alphaCompose Word8
coverage Word8
inverseCoverage Word8
backgroundAlpha Word8
_ =
Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32
div255 Word32
v
where fi :: Word8 -> Word32
fi :: Word8 -> Word32
fi = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
v :: Word32
v = Word8 -> Word32
fi Word8
coverage Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
255
Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word8 -> Word32
fi Word8
backgroundAlpha Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word8 -> Word32
fi Word8
inverseCoverage Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
128
{-# INLINE alphaOver #-}
alphaOver :: Word8 -> Word8 -> Word8 -> Word8 -> Word8
alphaOver Word8
coverage Word8
inverseCoverage Word8
background Word8
painted =
Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32
div255 Word32
v
where fi :: Word8 -> Word32
fi :: Word8 -> Word32
fi = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
v :: Word32
v = Word8 -> Word32
fi Word8
coverage Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word8 -> Word32
fi Word8
painted Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word8 -> Word32
fi Word8
background Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word8 -> Word32
fi Word8
inverseCoverage Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
128
toWord8 :: Float -> Int
{-# INLINE toWord8 #-}
toWord8 :: Float -> Int
toWord8 Float
r = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
255 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.5
compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px))
=> Compositor px
compositionDestination :: Compositor px
compositionDestination PixelBaseComponent px
c PixelBaseComponent px
_ px
_ = (PixelBaseComponent px -> PixelBaseComponent px) -> px -> px
forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap (PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px
forall a. Modulable a => a -> a -> a
modulate PixelBaseComponent px
c)
compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px))
=> Compositor px
{-# INLINE compositionAlpha #-}
compositionAlpha :: Compositor px
compositionAlpha PixelBaseComponent px
c PixelBaseComponent px
ic
| PixelBaseComponent px
c PixelBaseComponent px -> PixelBaseComponent px -> Bool
forall a. Eq a => a -> a -> Bool
== PixelBaseComponent px
forall a. Modulable a => a
emptyValue = px -> px -> px
forall a b. a -> b -> a
const
| PixelBaseComponent px
c PixelBaseComponent px -> PixelBaseComponent px -> Bool
forall a. Eq a => a -> a -> Bool
== PixelBaseComponent px
forall a. Modulable a => a
fullValue = \px
_ px
n -> px
n
| Bool
otherwise = \px
bottom px
top ->
let bottomOpacity :: PixelBaseComponent px
bottomOpacity = px -> PixelBaseComponent px
forall a. Pixel a => a -> PixelBaseComponent a
pixelOpacity px
bottom
alphaOut :: PixelBaseComponent px
alphaOut = PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
forall a. Modulable a => a -> a -> a -> a -> a
alphaCompose PixelBaseComponent px
c PixelBaseComponent px
ic PixelBaseComponent px
bottomOpacity (px -> PixelBaseComponent px
forall a. Pixel a => a -> PixelBaseComponent a
pixelOpacity px
top)
colorComposer :: Int
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
colorComposer Int
_ PixelBaseComponent px
back PixelBaseComponent px
fore =
PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
forall a. Modulable a => a -> a -> a -> a -> a
alphaOver PixelBaseComponent px
c PixelBaseComponent px
ic (PixelBaseComponent px
back PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px
forall a. Modulable a => a -> a -> a
`modulate` PixelBaseComponent px
bottomOpacity) PixelBaseComponent px
fore
PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px
forall a. Modulable a => a -> a -> a
`modiv` PixelBaseComponent px
alphaOut
in
(Int
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px)
-> (PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px)
-> px
-> px
-> px
forall a.
Pixel a =>
(Int
-> PixelBaseComponent a
-> PixelBaseComponent a
-> PixelBaseComponent a)
-> (PixelBaseComponent a
-> PixelBaseComponent a -> PixelBaseComponent a)
-> a
-> a
-> a
mixWithAlpha Int
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
colorComposer (\PixelBaseComponent px
_ PixelBaseComponent px
_ -> PixelBaseComponent px
alphaOut) px
bottom px
top
emptyPx :: (RenderablePixel px) => px
emptyPx :: px
emptyPx = (PixelBaseComponent px -> PixelBaseComponent px) -> px -> px
forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap (PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px
forall a b. a -> b -> a
const PixelBaseComponent px
forall a. Modulable a => a
emptyValue) (px -> px) -> px -> px
forall a b. (a -> b) -> a -> b
$ PackedRepresentation px -> px
forall a. PackeablePixel a => PackedRepresentation a -> a
unpackPixel PackedRepresentation px
0