{-# 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
, 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 ()
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
| 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
where
!fullOpacity :: PixelBaseComponent px
fullOpacity = PixelBaseComponent px
forall a. Modulable a => a
fullValue :: PixelBaseComponent px
!maxi :: Int
maxi = TextureSpaceInfo -> Int
_tsRepeat TextureSpaceInfo
tsInfo
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
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
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'
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)
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
-> Point
-> 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
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
-> Point
-> Float
-> 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
-> Point
-> Float
-> 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
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
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