module Graphics.Rasterific.Texture
( Texture
, Gradient
, withSampler
, uniformTexture
, linearGradientTexture
, radialGradientTexture
, radialGradientWithFocusTexture
, imageTexture
, sampledImageTexture
, modulateTexture
) where
import Data.Fixed( mod' )
import Linear( V2( .. )
, (^-^)
, (^/)
, dot
, norm
)
import qualified Data.Vector as V
import Codec.Picture.Types( Pixel( .. )
, Image( .. )
)
import Graphics.Rasterific.Types( Point, SamplerRepeat( .. ) )
import Graphics.Rasterific.Compositor
( Modulable( clampCoverage, modulate ), compositionAlpha )
type Texture px = SamplerRepeat -> Float -> Float -> px
withSampler :: SamplerRepeat -> Texture px -> Texture px
withSampler repeating texture _ = texture repeating
uniformTexture :: px
-> Texture px
uniformTexture px _ _ _ = px
type Gradient px = [(Float, px)]
type GradientArray px = V.Vector (Float, px)
repeatGradient :: Float -> Float
repeatGradient s = s fromIntegral (floor s :: Int)
reflectGradient :: Float -> Float
reflectGradient s =
abs (abs (s 1) `mod'` 2 1)
gradientColorAt :: (Pixel px, Modulable (PixelBaseComponent px))
=> GradientArray px -> Float -> px
gradientColorAt grad at
| at <= 0 = snd $ V.head grad
| at >= 1.0 = snd $ V.last grad
| otherwise = go (0, snd $ V.head grad) 0
where
maxi = V.length grad
go (prevCoeff, prevValue) ix
| ix >= maxi = snd $ V.last grad
| at < coeff = compositionAlpha cov icov prevValue px
| otherwise = go value $ ix + 1
where value@(coeff, px) = grad `V.unsafeIndex` ix
zeroToOne = (at prevCoeff) / (coeff prevCoeff)
(cov, icov) = clampCoverage zeroToOne
gradientColorAtRepeat :: (Pixel px, Modulable (PixelBaseComponent px))
=> SamplerRepeat -> GradientArray px -> Float -> px
gradientColorAtRepeat SamplerPad grad = gradientColorAt grad
gradientColorAtRepeat SamplerRepeat grad =
gradientColorAt grad . repeatGradient
gradientColorAtRepeat SamplerReflect grad =
gradientColorAt grad . reflectGradient
linearGradientTexture :: (Pixel px, Modulable (PixelBaseComponent px))
=> Gradient px
-> Point
-> Point
-> Texture px
linearGradientTexture gradient start end repeating =
\x y -> colorAt $ ((V2 x y) `dot` d) s00
where
colorAt = gradientColorAtRepeat repeating gradArray
gradArray = V.fromList gradient
vector = end ^-^ start
d = vector ^/ (vector `dot` vector)
s00 = start `dot` d
imageTexture :: forall px. (Pixel px) => Image px -> Texture px
imageTexture img _ x y =
unsafePixelAt rawData $ (clampedY * w + clampedX) * compCount
where
clampedX = min (w 1) . max 0 $ floor x
clampedY = min (h 1) . max 0 $ floor y
compCount = componentCount (undefined :: px)
w = imageWidth img
h = imageHeight img
rawData = imageData img
sampledImageTexture :: (Pixel px) => Image px -> Texture px
sampledImageTexture img SamplerPad = imageTexture img SamplerPad
sampledImageTexture img SamplerReflect = imageTexture img SamplerPad
sampledImageTexture img SamplerRepeat = \x y -> texture (x `mod'` w) (y `mod'` h)
where
texture = imageTexture img SamplerPad
w = fromIntegral $ imageWidth img
h = fromIntegral $ imageHeight img
radialGradientTexture :: (Pixel px, Modulable (PixelBaseComponent px))
=> Gradient px
-> Point
-> Float
-> Texture px
radialGradientTexture gradient center radius repeating =
\x y -> colorAt $ norm ((V2 x y) ^-^ center) / radius
where
colorAt = gradientColorAtRepeat repeating gradArray
gradArray = V.fromList gradient
radialGradientWithFocusTexture
:: (Pixel px, Modulable (PixelBaseComponent px))
=> Gradient px
-> Point
-> Float
-> Point
-> Texture px
radialGradientWithFocusTexture gradient center radius focusScreen repeating =
\x y -> colorAt . go $ (V2 x y) ^-^ center
where
focus@(V2 origFocusX origFocusY) = focusScreen ^-^ center
colorAt = gradientColorAtRepeat repeating gradArray
gradArray = V.fromList gradient
radiusSquared = radius * radius
dist = sqrt $ focus `dot` focus
clampedFocus@(V2 focusX focusY)
| dist <= r = focus
| otherwise = V2 (r * cos a) (r * sin a)
where a = atan2 origFocusY origFocusX
r = radius * 0.99
trivial = sqrt $ radiusSquared focusX * focusY
solutionOf (V2 x y) | x == focusX =
V2 focusX (if y > focusY then trivial else negate trivial)
solutionOf (V2 x y) = V2 xSolution $ slope * xSolution + yint
where
slope = (y focusY) / (x focusX)
yint = y (slope * x)
a = slope * slope + 1
b = 2 * slope * yint
c = yint * yint radiusSquared
det = sqrt $ b * b 4 * a * c
xSolution = (b + (if x < focusX then negate det else det)) / (2 * a)
go pos = sqrt $ curToFocus / distSquared
where
solution = solutionOf pos ^-^ clampedFocus
toFocus = pos ^-^ clampedFocus
distSquared = solution `dot` solution
curToFocus = toFocus `dot` toFocus
modulateTexture :: (Pixel px, Modulable (PixelBaseComponent px))
=> Texture px
-> Texture (PixelBaseComponent px)
-> Texture px
modulateTexture fullTexture modulator repeating = \x y ->
colorMap (modulate $ modulationTexture x y) $ full x y
where modulationTexture = modulator repeating
full = fullTexture repeating