{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
-- | Compositor handle the pixel composition, which

-- leads to texture composition.

-- Very much a work in progress

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

-- | Used for Coon patch rendering

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

-- | This constraint ensure that a type is a pixel

-- and we're allowed to modulate it's color components

-- generically.

type ModulablePixel px =
    ( Pixel px
    , PackeablePixel px
    , InterpolablePixel px
    , InterpolablePixel (PixelBaseComponent px)
    , Storable (PackedRepresentation px)
    , Modulable (PixelBaseComponent px))

-- | This constraint tells us that pixel component

-- must also be pixel and be the "bottom" of component,

-- we cannot go further than a PixelBaseComponent level.

--

-- Tested pixel types are PixelRGBA8 & Pixel8

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)
    )

-- | Typeclass intented at pixel value modulation.

-- May be throwed out soon.

class (Ord a, Num a) => Modulable a where
  -- | Empty value representing total transparency for the given type.

  emptyValue :: a
  -- | Full value representing total opacity for a given type.

  fullValue  :: a
  -- | Given a Float in [0; 1], return the coverage in [emptyValue; fullValue]

  -- The second value is the inverse coverage

  clampCoverage :: Float -> (a, a)

  -- | Modulate two elements, staying in the [emptyValue; fullValue] range.

  modulate :: a -> a -> a

  -- | Implement a division between two elements.

  modiv :: a -> a -> a

  alphaOver :: a -- ^ coverage

            -> a -- ^ inverse coverage

            -> a -- ^ background

            -> a -- ^ foreground

            -> a
  alphaCompose :: a -> a -> a -> a -> a

  -- | Like modulate but also return the inverse coverage.

  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
-- | Really need a "builder" function for pixel

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