{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
module Graphics.Rasterific.Shading
    ( transformTextureToFiller
    , sampledImageShader
    , plotOpaquePixel
    , unsafePlotOpaquePixel
    ) where

import Control.Monad.ST( ST )
import Control.Monad.Primitive( PrimState
                              -- one day (GHC >= 7.10 ?)

                              , PrimMonad
                              )
import Data.Fixed( mod' )
import Graphics.Rasterific.Command
import Graphics.Rasterific.BiSampleable
import Graphics.Rasterific.Linear
             ( V2( .. )
             , (^-^)
             , (^/)
             , dot
             , norm
             )

import qualified Data.Vector as V

import Codec.Picture.Types( Pixel( .. )
                          , Image( .. )
                          , MutableImage( .. )
                          , Pixel8
                          , PixelRGBA8
                          , unsafeWritePixelBetweenAt
                          , readPackedPixelAt
                          , writePackedPixelAt
                          )

import Graphics.Rasterific.Types( Point
                                , Vector
                                , Line( .. )
                                , SamplerRepeat( .. ) )
import Graphics.Rasterific.Transformations
import Graphics.Rasterific.Rasterize
import Graphics.Rasterific.PatchTypes
import Graphics.Rasterific.Compositor( Modulable( .. )
                                     , ModulablePixel
                                     , RenderablePixel
                                     , compositionAlpha )


data TextureSpaceInfo = TextureSpaceInfo
    { TextureSpaceInfo -> Point
_tsStart     :: {-# UNPACK #-} !Point
    , TextureSpaceInfo -> Point
_tsDelta     :: {-# UNPACK #-} !Vector
    , TextureSpaceInfo -> Float
_tsCoverage  :: {-# UNPACK #-} !Float
    , TextureSpaceInfo -> Int
_tsRepeat    :: {-# UNPACK #-} !Int
    , TextureSpaceInfo -> Int
_tsBaseIndex :: {-# UNPACK #-} !Int
    }
    deriving (TextureSpaceInfo -> TextureSpaceInfo -> Bool
(TextureSpaceInfo -> TextureSpaceInfo -> Bool)
-> (TextureSpaceInfo -> TextureSpaceInfo -> Bool)
-> Eq TextureSpaceInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextureSpaceInfo -> TextureSpaceInfo -> Bool
$c/= :: TextureSpaceInfo -> TextureSpaceInfo -> Bool
== :: TextureSpaceInfo -> TextureSpaceInfo -> Bool
$c== :: TextureSpaceInfo -> TextureSpaceInfo -> Bool
Eq, Int -> TextureSpaceInfo -> ShowS
[TextureSpaceInfo] -> ShowS
TextureSpaceInfo -> String
(Int -> TextureSpaceInfo -> ShowS)
-> (TextureSpaceInfo -> String)
-> ([TextureSpaceInfo] -> ShowS)
-> Show TextureSpaceInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextureSpaceInfo] -> ShowS
$cshowList :: [TextureSpaceInfo] -> ShowS
show :: TextureSpaceInfo -> String
$cshow :: TextureSpaceInfo -> String
showsPrec :: Int -> TextureSpaceInfo -> ShowS
$cshowsPrec :: Int -> TextureSpaceInfo -> ShowS
Show)

type CoverageFiller m px =
    MutableImage (PrimState m) px -> CoverageSpan -> m ()

type Filler m =
    TextureSpaceInfo -> m ()

-- | Right now, we must stick to ST, due to the fact that

-- we can't specialize with parameterized monad :(

solidColor :: forall s px . (ModulablePixel px)
           => px -> MutableImage s px -> Filler (ST s)
{-# SPECIALIZE solidColor :: PixelRGBA8 -> MutableImage s PixelRGBA8
                          -> TextureSpaceInfo -> ST s () #-}
{-# SPECIALIZE solidColor :: Pixel8 -> MutableImage s Pixel8
                          -> TextureSpaceInfo -> ST s () #-}
solidColor :: px -> MutableImage s px -> Filler (ST s)
solidColor px
color MutableImage s px
_ TextureSpaceInfo
tsInfo
    | px -> PixelBaseComponent px
forall a. Pixel a => a -> PixelBaseComponent a
pixelOpacity px
color PixelBaseComponent px -> PixelBaseComponent px -> Bool
forall a. Eq a => a -> a -> Bool
== PixelBaseComponent px
forall a. Modulable a => a
emptyValue Bool -> Bool -> Bool
|| TextureSpaceInfo -> Float
_tsCoverage TextureSpaceInfo
tsInfo Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 =
        () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
solidColor px
color MutableImage s px
img TextureSpaceInfo
tsInfo
    -- We are in the case fully opaque, so we can

    -- just overwrite what was there before

    | px -> PixelBaseComponent px
forall a. Pixel a => a -> PixelBaseComponent a
pixelOpacity px
color PixelBaseComponent px -> PixelBaseComponent px -> Bool
forall a. Eq a => a -> a -> Bool
== PixelBaseComponent px
fullOpacity Bool -> Bool -> Bool
&& TextureSpaceInfo -> Float
_tsCoverage TextureSpaceInfo
tsInfo Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
1 =
        MutableImage (PrimState (ST s)) px -> px -> Int -> Int -> ST s ()
forall (m :: * -> *) px.
(PrimMonad m, Pixel px, PackeablePixel px,
 Storable (PackedRepresentation px)) =>
MutableImage (PrimState m) px -> px -> Int -> Int -> m ()
unsafeWritePixelBetweenAt MutableImage s px
MutableImage (PrimState (ST s)) px
img px
color (TextureSpaceInfo -> Int
_tsBaseIndex TextureSpaceInfo
tsInfo) Int
maxi
        {-go 0 $ _tsBaseIndex tsInfo-}
  where
    !fullOpacity :: PixelBaseComponent px
fullOpacity = PixelBaseComponent px
forall a. Modulable a => a
fullValue :: PixelBaseComponent px
    !maxi :: Int
maxi = TextureSpaceInfo -> Int
_tsRepeat TextureSpaceInfo
tsInfo

-- We can be transparent, so perform alpha blending.

solidColor px
color MutableImage s px
img TextureSpaceInfo
tsInfo = Int -> Int -> ST s ()
go Int
0 (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ TextureSpaceInfo -> Int
_tsBaseIndex TextureSpaceInfo
tsInfo
  where
    !opacity :: PixelBaseComponent px
opacity = px -> PixelBaseComponent px
forall a. Pixel a => a -> PixelBaseComponent a
pixelOpacity px
color
    !(PixelBaseComponent px
scanCoverage,PixelBaseComponent px
_) = Float -> (PixelBaseComponent px, PixelBaseComponent px)
forall a. Modulable a => Float -> (a, a)
clampCoverage (Float -> (PixelBaseComponent px, PixelBaseComponent px))
-> Float -> (PixelBaseComponent px, PixelBaseComponent px)
forall a b. (a -> b) -> a -> b
$TextureSpaceInfo -> Float
_tsCoverage TextureSpaceInfo
tsInfo
    !(PixelBaseComponent px
cov, PixelBaseComponent px
icov) = PixelBaseComponent px
-> PixelBaseComponent px
-> (PixelBaseComponent px, PixelBaseComponent px)
forall a. Modulable a => a -> a -> (a, a)
coverageModulate PixelBaseComponent px
scanCoverage PixelBaseComponent px
opacity
    !maxi :: Int
maxi = TextureSpaceInfo -> Int
_tsRepeat TextureSpaceInfo
tsInfo
    !compCount :: Int
compCount = px -> Int
forall a. Pixel a => a -> Int
componentCount (px
forall a. HasCallStack => a
undefined :: px)

    go :: Int -> Int -> ST s ()
go Int
count  Int
_ | Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxi = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go !Int
count !Int
idx = do
      px
oldPixel <- MutableImage (PrimState (ST s)) px -> Int -> ST s px
forall (m :: * -> *) px.
(Pixel px, PackeablePixel px, Storable (PackedRepresentation px),
 PrimMonad m) =>
MutableImage (PrimState m) px -> Int -> m px
readPackedPixelAt MutableImage s px
MutableImage (PrimState (ST s)) px
img Int
idx
      MutableImage (PrimState (ST s)) px -> Int -> px -> ST s ()
forall px (m :: * -> *).
(Pixel px, PackeablePixel px, Storable (PackedRepresentation px),
 PrimMonad m) =>
MutableImage (PrimState m) px -> Int -> px -> m ()
writePackedPixelAt MutableImage s px
MutableImage (PrimState (ST s)) px
img Int
idx
        (px -> ST s ()) -> px -> ST s ()
forall a b. (a -> b) -> a -> b
$ Compositor px
forall px.
(Pixel px, Modulable (PixelBaseComponent px)) =>
Compositor px
compositionAlpha PixelBaseComponent px
cov PixelBaseComponent px
icov px
oldPixel px
color
      Int -> Int -> ST s ()
go (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
compCount


-- | Plot a single pixel on the resulting image.

plotOpaquePixel :: forall m px. (ModulablePixel px, PrimMonad m)
                => MutableImage (PrimState m) px -> px -> Int -> Int
                -> m ()
{-# INLINE plotOpaquePixel #-}
plotOpaquePixel :: MutableImage (PrimState m) px -> px -> Int -> Int -> m ()
plotOpaquePixel MutableImage (PrimState m) px
img px
_color Int
x Int
y
   | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| 
     Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= MutableImage (PrimState m) px -> Int
forall s a. MutableImage s a -> Int
mutableImageWidth MutableImage (PrimState m) px
img Bool -> Bool -> Bool
|| Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= MutableImage (PrimState m) px -> Int
forall s a. MutableImage s a -> Int
mutableImageHeight MutableImage (PrimState m) px
img = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
plotOpaquePixel MutableImage (PrimState m) px
img px
color Int
x Int
y = do
  let !idx :: Int
idx = (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* MutableImage (PrimState m) px -> Int
forall s a. MutableImage s a -> Int
mutableImageWidth MutableImage (PrimState m) px
img Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (px -> Int
forall a. Pixel a => a -> Int
componentCount (px
forall a. HasCallStack => a
undefined :: px))
  MutableImage (PrimState m) px -> Int -> px -> m ()
forall px (m :: * -> *).
(Pixel px, PackeablePixel px, Storable (PackedRepresentation px),
 PrimMonad m) =>
MutableImage (PrimState m) px -> Int -> px -> m ()
writePackedPixelAt MutableImage (PrimState m) px
img Int
idx px
color

-- | Plot a single pixel on the resulting image, no bounds check are

-- performed, ensure index is correct!

unsafePlotOpaquePixel :: forall m px. (ModulablePixel px, PrimMonad m)
                      => MutableImage (PrimState m) px -> px -> Int -> Int
                      -> m ()
{-# INLINE unsafePlotOpaquePixel #-}
unsafePlotOpaquePixel :: MutableImage (PrimState m) px -> px -> Int -> Int -> m ()
unsafePlotOpaquePixel MutableImage (PrimState m) px
img px
color Int
x Int
y = do
  let !idx :: Int
idx = (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* MutableImage (PrimState m) px -> Int
forall s a. MutableImage s a -> Int
mutableImageWidth MutableImage (PrimState m) px
img Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (px -> Int
forall a. Pixel a => a -> Int
componentCount (px
forall a. HasCallStack => a
undefined :: px))
  MutableImage (PrimState m) px -> Int -> px -> m ()
forall px (m :: * -> *).
(Pixel px, PackeablePixel px, Storable (PackedRepresentation px),
 PrimMonad m) =>
MutableImage (PrimState m) px -> Int -> px -> m ()
writePackedPixelAt MutableImage (PrimState m) px
img Int
idx px
color

shaderFiller :: forall s px . (ModulablePixel px)
             => ShaderFunction px -> MutableImage s px
             -> Filler (ST s)
{-# SPECIALIZE shaderFiller :: ShaderFunction PixelRGBA8
                            -> MutableImage s PixelRGBA8
                            -> Filler (ST s) #-}
{-# SPECIALIZE shaderFiller :: ShaderFunction Pixel8
                            -> MutableImage s Pixel8
                            -> Filler (ST s) #-}
shaderFiller :: ShaderFunction px -> MutableImage s px -> Filler (ST s)
shaderFiller ShaderFunction px
shader MutableImage s px
img TextureSpaceInfo
tsInfo =
    Int -> Int -> Float -> Float -> ST s ()
go Int
0 (TextureSpaceInfo -> Int
_tsBaseIndex TextureSpaceInfo
tsInfo) Float
xStart Float
yStart
  where
    !(PixelBaseComponent px
scanCoverage,PixelBaseComponent px
_) = Float -> (PixelBaseComponent px, PixelBaseComponent px)
forall a. Modulable a => Float -> (a, a)
clampCoverage (Float -> (PixelBaseComponent px, PixelBaseComponent px))
-> Float -> (PixelBaseComponent px, PixelBaseComponent px)
forall a b. (a -> b) -> a -> b
$TextureSpaceInfo -> Float
_tsCoverage TextureSpaceInfo
tsInfo
    !maxi :: Int
maxi = TextureSpaceInfo -> Int
_tsRepeat TextureSpaceInfo
tsInfo
    !compCount :: Int
compCount = px -> Int
forall a. Pixel a => a -> Int
componentCount (px
forall a. HasCallStack => a
undefined :: px)
    (V2 Float
xStart Float
yStart) = TextureSpaceInfo -> Point
_tsStart TextureSpaceInfo
tsInfo
    (V2 Float
dx Float
dy) = TextureSpaceInfo -> Point
_tsDelta TextureSpaceInfo
tsInfo

    go :: Int -> Int -> Float -> Float -> ST s ()
go Int
count  Int
_ Float
_ Float
_ | Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxi = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go !Int
count !Int
idx !Float
x !Float
y = do
      let !color :: px
color = ShaderFunction px
shader Float
x Float
y
          !opacity :: PixelBaseComponent px
opacity = px -> PixelBaseComponent px
forall a. Pixel a => a -> PixelBaseComponent a
pixelOpacity px
color
          (PixelBaseComponent px
cov, PixelBaseComponent px
icov) = PixelBaseComponent px
-> PixelBaseComponent px
-> (PixelBaseComponent px, PixelBaseComponent px)
forall a. Modulable a => a -> a -> (a, a)
coverageModulate PixelBaseComponent px
scanCoverage PixelBaseComponent px
opacity
      px
oldPixel <- MutableImage (PrimState (ST s)) px -> Int -> ST s px
forall (m :: * -> *) px.
(Pixel px, PackeablePixel px, Storable (PackedRepresentation px),
 PrimMonad m) =>
MutableImage (PrimState m) px -> Int -> m px
readPackedPixelAt MutableImage s px
MutableImage (PrimState (ST s)) px
img Int
idx
      MutableImage (PrimState (ST s)) px -> Int -> px -> ST s ()
forall px (m :: * -> *).
(Pixel px, PackeablePixel px, Storable (PackedRepresentation px),
 PrimMonad m) =>
MutableImage (PrimState m) px -> Int -> px -> m ()
writePackedPixelAt MutableImage s px
MutableImage (PrimState (ST s)) px
img Int
idx
        (px -> ST s ()) -> px -> ST s ()
forall a b. (a -> b) -> a -> b
$ Compositor px
forall px.
(Pixel px, Modulable (PixelBaseComponent px)) =>
Compositor px
compositionAlpha PixelBaseComponent px
cov PixelBaseComponent px
icov px
oldPixel px
color
      Int -> Int -> Float -> Float -> ST s ()
go (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
compCount) (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dx) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dy)

prepareInfoNoTransform :: (Pixel px)
                       => MutableImage s px -> CoverageSpan
                       -> TextureSpaceInfo
prepareInfoNoTransform :: MutableImage s px -> CoverageSpan -> TextureSpaceInfo
prepareInfoNoTransform MutableImage s px
img CoverageSpan
coverage = TextureSpaceInfo :: Point -> Point -> Float -> Int -> Int -> TextureSpaceInfo
TextureSpaceInfo
    { _tsStart :: Point
_tsStart     = Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (CoverageSpan -> Float
_coverageX CoverageSpan
coverage) (CoverageSpan -> Float
_coverageY CoverageSpan
coverage)
    , _tsDelta :: Point
_tsDelta     = Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
1 Float
0
    , _tsCoverage :: Float
_tsCoverage  = CoverageSpan -> Float
_coverageVal CoverageSpan
coverage
    , _tsRepeat :: Int
_tsRepeat    = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ CoverageSpan -> Float
_coverageLength CoverageSpan
coverage
    , _tsBaseIndex :: Int
_tsBaseIndex =
        MutableImage s px -> Int -> Int -> Int
forall a s. Pixel a => MutableImage s a -> Int -> Int -> Int
mutablePixelBaseIndex MutableImage s px
img (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ CoverageSpan -> Float
_coverageX CoverageSpan
coverage)
                                  (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ CoverageSpan -> Float
_coverageY CoverageSpan
coverage)
    }

prepareInfo :: (Pixel px)
            => Maybe Transformation -> MutableImage s px -> CoverageSpan
            -> TextureSpaceInfo
prepareInfo :: Maybe Transformation
-> MutableImage s px -> CoverageSpan -> TextureSpaceInfo
prepareInfo Maybe Transformation
Nothing MutableImage s px
img CoverageSpan
covSpan = MutableImage s px -> CoverageSpan -> TextureSpaceInfo
forall px s.
Pixel px =>
MutableImage s px -> CoverageSpan -> TextureSpaceInfo
prepareInfoNoTransform MutableImage s px
img CoverageSpan
covSpan
prepareInfo (Just Transformation
t) MutableImage s px
img CoverageSpan
covSpan = TextureSpaceInfo :: Point -> Point -> Float -> Int -> Int -> TextureSpaceInfo
TextureSpaceInfo
    { _tsStart :: Point
_tsStart     = Transformation -> Point -> Point
applyTransformation Transformation
t
                   (Point -> Point) -> Point -> Point
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (CoverageSpan -> Float
_coverageX CoverageSpan
covSpan) (CoverageSpan -> Float
_coverageY CoverageSpan
covSpan)
    , _tsDelta :: Point
_tsDelta     = Transformation -> Point -> Point
applyVectorTransformation Transformation
t (Point -> Point) -> Point -> Point
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
1 Float
0
    , _tsCoverage :: Float
_tsCoverage  = CoverageSpan -> Float
_coverageVal CoverageSpan
covSpan
    , _tsRepeat :: Int
_tsRepeat    = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ CoverageSpan -> Float
_coverageLength CoverageSpan
covSpan
    , _tsBaseIndex :: Int
_tsBaseIndex =
        MutableImage s px -> Int -> Int -> Int
forall a s. Pixel a => MutableImage s a -> Int -> Int -> Int
mutablePixelBaseIndex MutableImage s px
img (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ CoverageSpan -> Float
_coverageX CoverageSpan
covSpan)
                                  (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ CoverageSpan -> Float
_coverageY CoverageSpan
covSpan)
    }

combineTransform :: Maybe Transformation -> Transformation
                 -> Maybe Transformation
combineTransform :: Maybe Transformation -> Transformation -> Maybe Transformation
combineTransform Maybe Transformation
Nothing Transformation
a = Transformation -> Maybe Transformation
forall a. a -> Maybe a
Just Transformation
a
combineTransform (Just Transformation
v) Transformation
a = Transformation -> Maybe Transformation
forall a. a -> Maybe a
Just (Transformation -> Maybe Transformation)
-> Transformation -> Maybe Transformation
forall a b. (a -> b) -> a -> b
$ Transformation
v Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation
a

withTrans :: Maybe Transformation -> ShaderFunction px
          -> ShaderFunction px
withTrans :: Maybe Transformation -> ShaderFunction px -> ShaderFunction px
withTrans Maybe Transformation
Nothing ShaderFunction px
shader = ShaderFunction px
shader
withTrans (Just Transformation
v) ShaderFunction px
shader = \Float
x Float
y ->
    let V2 Float
x' Float
y' = Transformation -> Point -> Point
applyTransformation Transformation
v (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
x Float
y) in
    ShaderFunction px
shader Float
x' Float
y'

-- | The intent of shader texture is to provide ease of implementation

-- If possible providing a custom filler will be more efficient,

-- like already done for the solid colors.

shaderOfTexture :: forall px . RenderablePixel px
                => Maybe Transformation -> SamplerRepeat -> Texture px
                -> ShaderFunction px
{-# SPECIALIZE
    shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture PixelRGBA8
                    -> ShaderFunction PixelRGBA8 #-}
{-# SPECIALIZE
    shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture Pixel8
                    -> ShaderFunction Pixel8 #-}
shaderOfTexture :: Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
shaderOfTexture Maybe Transformation
_ SamplerRepeat
_ (SolidTexture px
px) = \Float
_ Float
_ -> px
px
shaderOfTexture Maybe Transformation
_ SamplerRepeat
_ (MeshPatchTexture PatchInterpolation
_ MeshPatch px
_) = String -> ShaderFunction px
forall a. HasCallStack => String -> a
error String
"MeshPatch should be precomputed"
shaderOfTexture Maybe Transformation
trans SamplerRepeat
sampling (LinearGradientTexture Gradient px
grad (Line Point
a Point
b)) =
  Maybe Transformation -> ShaderFunction px -> ShaderFunction px
forall px.
Maybe Transformation -> ShaderFunction px -> ShaderFunction px
withTrans Maybe Transformation
trans (ShaderFunction px -> ShaderFunction px)
-> ShaderFunction px -> ShaderFunction px
forall a b. (a -> b) -> a -> b
$ Gradient px -> Point -> Point -> SamplerRepeat -> ShaderFunction px
forall px.
ModulablePixel px =>
Gradient px -> Point -> Point -> SamplerRepeat -> ShaderFunction px
linearGradientShader Gradient px
grad Point
a Point
b SamplerRepeat
sampling
shaderOfTexture Maybe Transformation
trans SamplerRepeat
sampling (RadialGradientTexture Gradient px
grad Point
center Float
radius) =
  Maybe Transformation -> ShaderFunction px -> ShaderFunction px
forall px.
Maybe Transformation -> ShaderFunction px -> ShaderFunction px
withTrans Maybe Transformation
trans (ShaderFunction px -> ShaderFunction px)
-> ShaderFunction px -> ShaderFunction px
forall a b. (a -> b) -> a -> b
$ Gradient px -> Point -> Float -> SamplerRepeat -> ShaderFunction px
forall px.
ModulablePixel px =>
Gradient px -> Point -> Float -> SamplerRepeat -> ShaderFunction px
radialGradientShader Gradient px
grad Point
center Float
radius SamplerRepeat
sampling
shaderOfTexture Maybe Transformation
trans SamplerRepeat
sampling (RadialGradientWithFocusTexture Gradient px
grad Point
center 
                                                    Float
radius Point
focus) =
  Maybe Transformation -> ShaderFunction px -> ShaderFunction px
forall px.
Maybe Transformation -> ShaderFunction px -> ShaderFunction px
withTrans Maybe Transformation
trans
             (ShaderFunction px -> ShaderFunction px)
-> ShaderFunction px -> ShaderFunction px
forall a b. (a -> b) -> a -> b
$ Gradient px
-> Point -> Float -> Point -> SamplerRepeat -> ShaderFunction px
forall px.
ModulablePixel px =>
Gradient px
-> Point -> Float -> Point -> SamplerRepeat -> ShaderFunction px
radialGradientWithFocusShader Gradient px
grad Point
center Float
radius Point
focus
                                              SamplerRepeat
sampling
shaderOfTexture Maybe Transformation
trans SamplerRepeat
_ (WithSampler SamplerRepeat
sampler Texture px
sub) =
  Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
forall px.
RenderablePixel px =>
Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
shaderOfTexture Maybe Transformation
trans SamplerRepeat
sampler Texture px
sub
shaderOfTexture Maybe Transformation
trans SamplerRepeat
sampling (WithTextureTransform Transformation
transform Texture px
sub) =
  Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
forall px.
RenderablePixel px =>
Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
shaderOfTexture (Maybe Transformation -> Transformation -> Maybe Transformation
combineTransform Maybe Transformation
trans Transformation
transform) SamplerRepeat
sampling Texture px
sub
shaderOfTexture Maybe Transformation
trans SamplerRepeat
sampling (SampledTexture Image px
img) =
  Maybe Transformation -> ShaderFunction px -> ShaderFunction px
forall px.
Maybe Transformation -> ShaderFunction px -> ShaderFunction px
withTrans Maybe Transformation
trans (ShaderFunction px -> ShaderFunction px)
-> ShaderFunction px -> ShaderFunction px
forall a b. (a -> b) -> a -> b
$ Image px -> SamplerRepeat -> ShaderFunction px
forall px.
RenderablePixel px =>
Image px -> SamplerRepeat -> ShaderFunction px
sampledImageShader Image px
img SamplerRepeat
sampling
shaderOfTexture Maybe Transformation
trans SamplerRepeat
_ (ShaderTexture ShaderFunction px
func) =
  Maybe Transformation -> ShaderFunction px -> ShaderFunction px
forall px.
Maybe Transformation -> ShaderFunction px -> ShaderFunction px
withTrans Maybe Transformation
trans ShaderFunction px
func
shaderOfTexture Maybe Transformation
trans SamplerRepeat
_ (RawTexture Image px
img) =
  Maybe Transformation -> ShaderFunction px -> ShaderFunction px
forall px.
Maybe Transformation -> ShaderFunction px -> ShaderFunction px
withTrans Maybe Transformation
trans (ShaderFunction px -> ShaderFunction px)
-> ShaderFunction px -> ShaderFunction px
forall a b. (a -> b) -> a -> b
$ Image px -> ShaderFunction px
forall px. Pixel px => Image px -> ShaderFunction px
imageShader Image px
img
shaderOfTexture Maybe Transformation
trans SamplerRepeat
_sampling (PatternTexture Int
_ Int
_ px
_ Drawing px ()
_ Image px
img) =
  Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
forall px.
RenderablePixel px =>
Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
shaderOfTexture Maybe Transformation
trans SamplerRepeat
SamplerRepeat (Texture px -> ShaderFunction px)
-> Texture px -> ShaderFunction px
forall a b. (a -> b) -> a -> b
$ Image px -> Texture px
forall px. Image px -> Texture px
SampledTexture Image px
img
shaderOfTexture Maybe Transformation
trans SamplerRepeat
sampling (ModulateTexture Texture px
texture Texture (PixelBaseComponent px)
modulation) =
  ShaderFunction px
-> ShaderFunction (PixelBaseComponent px) -> ShaderFunction px
forall px.
ModulablePixel px =>
ShaderFunction px
-> ShaderFunction (PixelBaseComponent px) -> ShaderFunction px
modulateTexture (Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
forall px.
RenderablePixel px =>
Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
shaderOfTexture Maybe Transformation
trans SamplerRepeat
sampling Texture px
texture)
                  (Maybe Transformation
-> SamplerRepeat
-> Texture (PixelBaseComponent px)
-> ShaderFunction (PixelBaseComponent px)
forall px.
RenderablePixel px =>
Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
shaderOfTexture Maybe Transformation
trans SamplerRepeat
sampling Texture (PixelBaseComponent px)
modulation)
shaderOfTexture Maybe Transformation
trans SamplerRepeat
sampling (AlphaModulateTexture Texture px
texture Texture (PixelBaseComponent px)
modulation) =
  ShaderFunction px
-> ShaderFunction (PixelBaseComponent px) -> ShaderFunction px
forall px.
ModulablePixel px =>
ShaderFunction px
-> ShaderFunction (PixelBaseComponent px) -> ShaderFunction px
alphaModulateTexture
    (Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
forall px.
RenderablePixel px =>
Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
shaderOfTexture Maybe Transformation
trans SamplerRepeat
sampling Texture px
texture)
    (Maybe Transformation
-> SamplerRepeat
-> Texture (PixelBaseComponent px)
-> ShaderFunction (PixelBaseComponent px)
forall px.
RenderablePixel px =>
Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
shaderOfTexture Maybe Transformation
trans SamplerRepeat
sampling Texture (PixelBaseComponent px)
modulation)


-- | This function will interpret the texture description, helping

-- prepare and optimize the real calculation

transformTextureToFiller
    :: (RenderablePixel px)
    => (Maybe Transformation -> Int -> Int -> PatchInterpolation -> MeshPatch px -> Image px)
    -> Texture px -> CoverageFiller (ST s) px
transformTextureToFiller :: (Maybe Transformation
 -> Int -> Int -> PatchInterpolation -> MeshPatch px -> Image px)
-> Texture px -> CoverageFiller (ST s) px
transformTextureToFiller Maybe Transformation
-> Int -> Int -> PatchInterpolation -> MeshPatch px -> Image px
renderMesh = Maybe Transformation
-> SamplerRepeat
-> Texture px
-> MutableImage s px
-> CoverageSpan
-> ST s ()
go Maybe Transformation
forall a. Maybe a
Nothing SamplerRepeat
SamplerPad
  where
    go :: Maybe Transformation
-> SamplerRepeat
-> Texture px
-> MutableImage s px
-> CoverageSpan
-> ST s ()
go Maybe Transformation
_ SamplerRepeat
_ (SolidTexture px
px) =
        \MutableImage s px
img -> px -> MutableImage s px -> Filler (ST s)
forall s px.
ModulablePixel px =>
px -> MutableImage s px -> Filler (ST s)
solidColor px
px MutableImage s px
img Filler (ST s)
-> (CoverageSpan -> TextureSpaceInfo) -> CoverageSpan -> ST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MutableImage s px -> CoverageSpan -> TextureSpaceInfo
forall px s.
Pixel px =>
MutableImage s px -> CoverageSpan -> TextureSpaceInfo
prepareInfoNoTransform MutableImage s px
img
    go Maybe Transformation
trans SamplerRepeat
sampling (WithTextureTransform Transformation
transform Texture px
sub) =
        Maybe Transformation
-> SamplerRepeat
-> Texture px
-> MutableImage s px
-> CoverageSpan
-> ST s ()
go (Maybe Transformation -> Transformation -> Maybe Transformation
combineTransform Maybe Transformation
trans Transformation
transform) SamplerRepeat
sampling Texture px
sub
    go Maybe Transformation
trans SamplerRepeat
_ (WithSampler SamplerRepeat
sampler Texture px
sub) =
        Maybe Transformation
-> SamplerRepeat
-> Texture px
-> MutableImage s px
-> CoverageSpan
-> ST s ()
go Maybe Transformation
trans SamplerRepeat
sampler Texture px
sub
    go Maybe Transformation
trans SamplerRepeat
sampling (MeshPatchTexture PatchInterpolation
i MeshPatch px
m) = \MutableImage s px
img ->
      let newImg :: Image px
newImg = Maybe Transformation
-> Int -> Int -> PatchInterpolation -> MeshPatch px -> Image px
renderMesh
            Maybe Transformation
trans
            (MutableImage s px -> Int
forall s a. MutableImage s a -> Int
mutableImageWidth MutableImage s px
img)
            (MutableImage s px -> Int
forall s a. MutableImage s a -> Int
mutableImageHeight MutableImage s px
img)
            PatchInterpolation
i
            MeshPatch px
m
      in
      Maybe Transformation
-> SamplerRepeat
-> Texture px
-> MutableImage s px
-> CoverageSpan
-> ST s ()
go Maybe Transformation
forall a. Maybe a
Nothing SamplerRepeat
sampling (Image px -> Texture px
forall px. Image px -> Texture px
RawTexture Image px
newImg) MutableImage s px
img
        
    go Maybe Transformation
trans SamplerRepeat
sampling Texture px
tex =
        \MutableImage s px
img -> ShaderFunction px -> MutableImage s px -> Filler (ST s)
forall s px.
ModulablePixel px =>
ShaderFunction px -> MutableImage s px -> Filler (ST s)
shaderFiller ShaderFunction px
shader MutableImage s px
img Filler (ST s)
-> (CoverageSpan -> TextureSpaceInfo) -> CoverageSpan -> ST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Transformation
-> MutableImage s px -> CoverageSpan -> TextureSpaceInfo
forall px s.
Pixel px =>
Maybe Transformation
-> MutableImage s px -> CoverageSpan -> TextureSpaceInfo
prepareInfo Maybe Transformation
trans MutableImage s px
img
            where shader :: ShaderFunction px
shader = Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
forall px.
RenderablePixel px =>
Maybe Transformation
-> SamplerRepeat -> Texture px -> ShaderFunction px
shaderOfTexture Maybe Transformation
forall a. Maybe a
Nothing SamplerRepeat
sampling Texture px
tex

type GradientArray px = V.Vector (Float, px)

repeatGradient :: Float -> Float
repeatGradient :: Float -> Float
repeatGradient Float
s = Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
- Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
s :: Int)

reflectGradient :: Float -> Float
reflectGradient :: Float -> Float
reflectGradient Float
s =
    Float -> Float
forall a. Num a => a -> a
abs (Float -> Float
forall a. Num a => a -> a
abs (Float
s Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
1) Float -> Float -> Float
forall a. Real a => a -> a -> a
`mod'` Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
1)
   
gradientColorAt :: ModulablePixel px
                => GradientArray px -> Float -> px
{-# SPECIALIZE
     gradientColorAt :: GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-}
{-# SPECIALIZE
     gradientColorAt :: GradientArray Pixel8 -> Float -> Pixel8 #-}
gradientColorAt :: GradientArray px -> Float -> px
gradientColorAt GradientArray px
grad Float
at
    | Float
at Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = (Float, px) -> px
forall a b. (a, b) -> b
snd ((Float, px) -> px) -> (Float, px) -> px
forall a b. (a -> b) -> a -> b
$ GradientArray px -> (Float, px)
forall a. Vector a -> a
V.head GradientArray px
grad
    | Float
at Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
1.0 = (Float, px) -> px
forall a b. (a, b) -> b
snd ((Float, px) -> px) -> (Float, px) -> px
forall a b. (a -> b) -> a -> b
$ GradientArray px -> (Float, px)
forall a. Vector a -> a
V.last GradientArray px
grad
    | Bool
otherwise = (Float, px) -> Int -> px
go (Float
0, (Float, px) -> px
forall a b. (a, b) -> b
snd ((Float, px) -> px) -> (Float, px) -> px
forall a b. (a -> b) -> a -> b
$ GradientArray px -> (Float, px)
forall a. Vector a -> a
V.head GradientArray px
grad) Int
0
  where
    !maxi :: Int
maxi = GradientArray px -> Int
forall a. Vector a -> Int
V.length GradientArray px
grad
    go :: (Float, px) -> Int -> px
go (Float
prevCoeff, px
prevValue) Int
ix
      | Int
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxi = (Float, px) -> px
forall a b. (a, b) -> b
snd ((Float, px) -> px) -> (Float, px) -> px
forall a b. (a -> b) -> a -> b
$ GradientArray px -> (Float, px)
forall a. Vector a -> a
V.last GradientArray px
grad
      | Float
at Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
coeff = (Int
 -> PixelBaseComponent px
 -> PixelBaseComponent px
 -> PixelBaseComponent px)
-> px -> px -> px
forall a.
Pixel a =>
(Int
 -> PixelBaseComponent a
 -> PixelBaseComponent a
 -> PixelBaseComponent a)
-> a -> a -> a
mixWith (\Int
_ -> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
forall a. Modulable a => a -> a -> a -> a -> a
alphaOver PixelBaseComponent px
cov PixelBaseComponent px
icov) px
prevValue px
px
      | Bool
otherwise = (Float, px) -> Int -> px
go (Float, px)
value (Int -> px) -> Int -> px
forall a b. (a -> b) -> a -> b
$ Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      where value :: (Float, px)
value@(Float
coeff, px
px) = GradientArray px
grad GradientArray px -> Int -> (Float, px)
forall a. Vector a -> Int -> a
`V.unsafeIndex` Int
ix
            zeroToOne :: Float
zeroToOne = (Float
at Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
prevCoeff) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
coeff Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
prevCoeff)
            (PixelBaseComponent px
cov, PixelBaseComponent px
icov) = Float -> (PixelBaseComponent px, PixelBaseComponent px)
forall a. Modulable a => Float -> (a, a)
clampCoverage Float
zeroToOne

gradientColorAtRepeat :: ModulablePixel px
                      => SamplerRepeat -> GradientArray px -> Float -> px
{-# SPECIALIZE INLINE
    gradientColorAtRepeat ::
        SamplerRepeat -> GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-}
{-# SPECIALIZE INLINE
    gradientColorAtRepeat ::
        SamplerRepeat -> GradientArray Pixel8 -> Float -> Pixel8 #-}
gradientColorAtRepeat :: SamplerRepeat -> GradientArray px -> Float -> px
gradientColorAtRepeat SamplerRepeat
SamplerPad GradientArray px
grad = GradientArray px -> Float -> px
forall px. ModulablePixel px => GradientArray px -> Float -> px
gradientColorAt GradientArray px
grad
gradientColorAtRepeat SamplerRepeat
SamplerRepeat GradientArray px
grad =
    GradientArray px -> Float -> px
forall px. ModulablePixel px => GradientArray px -> Float -> px
gradientColorAt GradientArray px
grad (Float -> px) -> (Float -> Float) -> Float -> px
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float
repeatGradient
gradientColorAtRepeat SamplerRepeat
SamplerReflect GradientArray px
grad =
    GradientArray px -> Float -> px
forall px. ModulablePixel px => GradientArray px -> Float -> px
gradientColorAt GradientArray px
grad (Float -> px) -> (Float -> Float) -> Float -> px
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float
reflectGradient

linearGradientShader :: ModulablePixel px
                     => Gradient px -- ^ Gradient description.

                     -> Point       -- ^ Linear gradient start point.

                     -> Point       -- ^ Linear gradient end point.

                     -> SamplerRepeat
                     -> ShaderFunction px
{-# SPECIALIZE linearGradientShader
                     :: Gradient PixelRGBA8 -> Point -> Point -> SamplerRepeat
                     -> ShaderFunction PixelRGBA8 #-}
{-# SPECIALIZE linearGradientShader
                     :: Gradient Pixel8 -> Point -> Point -> SamplerRepeat
                     -> ShaderFunction Pixel8 #-}
linearGradientShader :: Gradient px -> Point -> Point -> SamplerRepeat -> ShaderFunction px
linearGradientShader Gradient px
gradient Point
start Point
end SamplerRepeat
repeating =
    \Float
x Float
y -> Float -> px
colorAt (Float -> px) -> Float -> px
forall a b. (a -> b) -> a -> b
$ (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
x Float
y Point -> Point -> Float
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Point
d) Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
s00
  where
    colorAt :: Float -> px
colorAt = SamplerRepeat -> GradientArray px -> Float -> px
forall px.
ModulablePixel px =>
SamplerRepeat -> GradientArray px -> Float -> px
gradientColorAtRepeat SamplerRepeat
repeating GradientArray px
gradArray
    gradArray :: GradientArray px
gradArray = Gradient px -> GradientArray px
forall a. [a] -> Vector a
V.fromList Gradient px
gradient
    vector :: Point
vector = Point
end Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
start
    d :: Point
d = Point
vector Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Floating a) => f a -> a -> f a
^/ (Point
vector Point -> Point -> Float
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Point
vector)
    s00 :: Float
s00 = Point
start Point -> Point -> Float
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Point
d

-- | Use another image as a texture for the filling.

-- This texture use the "nearest" filtering, AKA no

-- filtering at all.

imageShader :: forall px. (Pixel px) => Image px -> ShaderFunction px
{-# SPECIALIZE
    imageShader :: Image PixelRGBA8 -> ShaderFunction PixelRGBA8 #-}
{-# SPECIALIZE
    imageShader :: Image Pixel8 -> ShaderFunction Pixel8 #-}
imageShader :: Image px -> ShaderFunction px
imageShader Image px
img Float
x Float
y =
    Vector (PixelBaseComponent px) -> Int -> px
forall a. Pixel a => Vector (PixelBaseComponent a) -> Int -> a
unsafePixelAt Vector (PixelBaseComponent px)
rawData (Int -> px) -> Int -> px
forall a b. (a -> b) -> a -> b
$ (Int
clampedY Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
clampedX) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
compCount
  where
   clampedX :: Int
clampedX = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
x
   clampedY :: Int
clampedY = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
y
   !compCount :: Int
compCount = px -> Int
forall a. Pixel a => a -> Int
componentCount (px
forall a. HasCallStack => a
undefined :: px)
   !w :: Int
w = Image px -> Int
forall a. Image a -> Int
imageWidth Image px
img
   !h :: Int
h = Image px -> Int
forall a. Image a -> Int
imageHeight Image px
img
   !rawData :: Vector (PixelBaseComponent px)
rawData = Image px -> Vector (PixelBaseComponent px)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image px
img

radialGradientShader :: ModulablePixel px
                     => Gradient px -- ^ Gradient description

                     -> Point       -- ^ Radial gradient center

                     -> Float       -- ^ Radial gradient radius

                     -> SamplerRepeat
                     -> ShaderFunction px
{-# SPECIALIZE 
    radialGradientShader
       :: Gradient PixelRGBA8 -> Point -> Float -> SamplerRepeat
       -> ShaderFunction PixelRGBA8 #-}
{-# SPECIALIZE 
    radialGradientShader
       :: Gradient Pixel8 -> Point -> Float -> SamplerRepeat
       -> ShaderFunction Pixel8 #-}
radialGradientShader :: Gradient px -> Point -> Float -> SamplerRepeat -> ShaderFunction px
radialGradientShader Gradient px
gradient Point
center Float
radius SamplerRepeat
repeating =
    \Float
x Float
y -> Float -> px
colorAt (Float -> px) -> Float -> px
forall a b. (a -> b) -> a -> b
$ Point -> Float
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
x Float
y Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
center) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
radius
  where
    !colorAt :: Float -> px
colorAt = SamplerRepeat -> GradientArray px -> Float -> px
forall px.
ModulablePixel px =>
SamplerRepeat -> GradientArray px -> Float -> px
gradientColorAtRepeat SamplerRepeat
repeating GradientArray px
gradArray
    !gradArray :: GradientArray px
gradArray = Gradient px -> GradientArray px
forall a. [a] -> Vector a
V.fromList Gradient px
gradient

radialGradientWithFocusShader
    :: ModulablePixel px
    => Gradient px -- ^ Gradient description

    -> Point      -- ^ Radial gradient center

    -> Float      -- ^ Radial gradient radius

    -> Point      -- ^ Radial gradient focus point

    -> SamplerRepeat
    -> ShaderFunction px
{-# SPECIALIZE
    radialGradientWithFocusShader
        :: Gradient PixelRGBA8 -> Point -> Float -> Point
        -> SamplerRepeat -> ShaderFunction PixelRGBA8 #-}
{-# SPECIALIZE
    radialGradientWithFocusShader
        :: Gradient Pixel8 -> Point -> Float -> Point
        -> SamplerRepeat -> ShaderFunction Pixel8 #-}
radialGradientWithFocusShader :: Gradient px
-> Point -> Float -> Point -> SamplerRepeat -> ShaderFunction px
radialGradientWithFocusShader Gradient px
gradient Point
center Float
radius Point
focusScreen SamplerRepeat
repeating =
    \Float
x Float
y -> Float -> px
colorAt (Float -> px) -> (Point -> Float) -> Point -> px
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Float
go (Point -> px) -> Point -> px
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
x Float
y Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
center
  where
    focus :: Point
focus@(V2 Float
origFocusX Float
origFocusY) = Point
focusScreen Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
center
    colorAt :: Float -> px
colorAt = SamplerRepeat -> GradientArray px -> Float -> px
forall px.
ModulablePixel px =>
SamplerRepeat -> GradientArray px -> Float -> px
gradientColorAtRepeat SamplerRepeat
repeating GradientArray px
gradArray
    gradArray :: GradientArray px
gradArray = Gradient px -> GradientArray px
forall a. [a] -> Vector a
V.fromList Gradient px
gradient
    radiusSquared :: Float
radiusSquared = Float
radius Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
radius
    dist :: Float
dist = Float -> Float
forall a. Floating a => a -> a
sqrt (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$ Point
focus Point -> Point -> Float
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Point
focus
    clampedFocus :: Point
clampedFocus@(V2 Float
focusX Float
focusY)
        | Float
dist Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
r = Point
focus
        | Bool
otherwise = Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
forall a. Floating a => a -> a
cos Float
a) (Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
forall a. Floating a => a -> a
sin Float
a)
           where a :: Float
a = Float -> Float -> Float
forall a. RealFloat a => a -> a -> a
atan2 Float
origFocusY Float
origFocusX
                 r :: Float
r = Float
radius Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.99
    trivial :: Float
trivial = Float -> Float
forall a. Floating a => a -> a
sqrt (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$ Float
radiusSquared Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
origFocusX Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
origFocusX

    solutionOf :: Point -> Point
solutionOf (V2 Float
x Float
y) | Float
x Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
focusX =
        Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
focusX (if Float
y Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
focusY then Float
trivial else Float -> Float
forall a. Num a => a -> a
negate Float
trivial)
    solutionOf (V2 Float
x Float
y) = Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
xSolution (Float -> Point) -> Float -> Point
forall a b. (a -> b) -> a -> b
$ Float
slope Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
xSolution Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
yint
      where
        slope :: Float
slope = (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
focusY) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
focusX)
        yint :: Float
yint = Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
- (Float
slope Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
x)

        a :: Float
a = Float
slope Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
slope Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
1
        b :: Float
b = Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
slope Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
yint
        c :: Float
c = Float
yint Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
yint Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
radiusSquared
        det :: Float
det = Float -> Float
forall a. Floating a => a -> a
sqrt (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$ Float
b Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
b Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
4 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
a Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
c
        xSolution :: Float
xSolution = (-Float
b Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (if Float
x Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
focusX then Float -> Float
forall a. Num a => a -> a
negate Float
det else Float
det)) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
a)

    go :: Point -> Float
go Point
pos = Float -> Float
forall a. Floating a => a -> a
sqrt (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$ Float
curToFocus Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
distSquared
      where
        solution :: Point
solution = Point -> Point
solutionOf Point
pos Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
clampedFocus
        toFocus :: Point
toFocus = Point
pos Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
clampedFocus
        distSquared :: Float
distSquared = Point
solution Point -> Point -> Float
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Point
solution
        curToFocus :: Float
curToFocus = Point
toFocus Point -> Point -> Float
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Point
toFocus

-- | Perform a multiplication operation between a full color texture

-- and a greyscale one, used for clip-path implementation.

modulateTexture :: ModulablePixel px
                => ShaderFunction px
                -> ShaderFunction (PixelBaseComponent px)
                -> ShaderFunction px
{-# INLINE modulateTexture #-}
modulateTexture :: ShaderFunction px
-> ShaderFunction (PixelBaseComponent px) -> ShaderFunction px
modulateTexture ShaderFunction px
fullTexture ShaderFunction (PixelBaseComponent px)
modulator Float
x Float
y =
    (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
 -> PixelBaseComponent px -> PixelBaseComponent px)
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
forall a b. (a -> b) -> a -> b
$ ShaderFunction (PixelBaseComponent px)
modulator Float
x Float
y) (px -> px) -> px -> px
forall a b. (a -> b) -> a -> b
$ ShaderFunction px
fullTexture Float
x Float
y

-- | Perform a multiplication operation between a full color texture

-- and a greyscale one, used for clip-path implementation.

alphaModulateTexture :: ModulablePixel px
                => ShaderFunction px
                -> ShaderFunction (PixelBaseComponent px)
                -> ShaderFunction px
{-# INLINE alphaModulateTexture #-}
alphaModulateTexture :: ShaderFunction px
-> ShaderFunction (PixelBaseComponent px) -> ShaderFunction px
alphaModulateTexture ShaderFunction px
fullTexture ShaderFunction (PixelBaseComponent px)
modulator Float
x Float
y =
  let px :: px
px = ShaderFunction px
fullTexture Float
x Float
y 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
a -> PixelBaseComponent px
a) (\PixelBaseComponent px
_ PixelBaseComponent px
_ -> ShaderFunction (PixelBaseComponent px)
modulator Float
x Float
y) px
px px
px