module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), Pattern(..),
RadialShape(..), Resize(..), Length(..), Extent(..),
resolveSize, renderBackgrounds) where
import Graphics.Rendering.Rect.CSS.Backgrounds
import Graphics.Rendering.Rect.Types
import Graphics.Rendering.Rect.Image (Texture(texSize), textureSetRepeat)
import qualified Data.ByteString.Char8 as B8
import Linear (M44, V2(..))
import Control.Monad.IO.Class (MonadIO(..))
import Data.Maybe (fromMaybe, listToMaybe)
import Control.Monad (forM)
baseFragmentShader :: B8.ByteString
baseFragmentShader :: ByteString
baseFragmentShader = String -> ByteString
B8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [
"#version 330 core",
"out vec4 fcolour;",
"uniform vec4 colour;",
"void main() { fcolour = colour; }"
]
imageFragmentShader :: B8.ByteString
imageFragmentShader :: ByteString
imageFragmentShader = String -> ByteString
B8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [
"#version 330 core",
"in vec2 coord;",
"out vec4 fcolour;",
"uniform vec2 pos;",
"uniform sampler2D image;",
"uniform vec2 size;",
"void main() { fcolour = texture(image, coord/size - pos/size); }"
]
linearFragmentShader :: B8.ByteString
linearFragmentShader :: ByteString
linearFragmentShader = String -> ByteString
B8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [
"#version 330 core",
"in vec2 coord;",
"out vec4 fcolour;",
"uniform vec2 size;",
"uniform vec4 stops[10];",
"uniform float stopPoints[10];",
"uniform int nStops;",
"uniform float angle;",
"",
"void main() {",
" vec2 pos = coord/size;",
" pos -= 0.5; pos *= 2;",
" float a = pos.x*sin(angle) + pos.y*-cos(angle);",
" a /= 2; a += 0.5;",
"",
" int i = 0;",
" if (1 < nStops - 1 && a > stopPoints[1]) i = 1;",
" if (2 < nStops - 1 && a > stopPoints[2]) i = 2;",
" if (3 < nStops - 1 && a > stopPoints[3]) i = 3;",
" if (4 < nStops - 1 && a > stopPoints[4]) i = 4;",
" if (5 < nStops - 1 && a > stopPoints[5]) i = 5;",
" if (6 < nStops - 1 && a > stopPoints[6]) i = 6;",
" if (7 < nStops - 1 && a > stopPoints[7]) i = 7;",
" if (8 < nStops - 1 && a > stopPoints[8]) i = 8;",
"",
" a = smoothstep(stopPoints[i], stopPoints[i+1], a);",
" fcolour = mix(stops[i], stops[i+1], a);",
"}"
]
radialFragmentShader :: B8.ByteString
radialFragmentShader :: ByteString
radialFragmentShader = String -> ByteString
B8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [
"#version 330 core",
"in vec2 coord;",
"out vec4 fcolour;",
"uniform vec2 size;",
"uniform vec2 extent;",
"uniform vec2 center;",
"uniform vec4 stops[10];",
"uniform float stopPoints[10];",
"uniform int nStops;",
"",
"void main() {",
" float a = distance(coord/extent, center/size) * 2;",
"",
" int i = 0;",
" if (1 < nStops - 1 && a > stopPoints[1]) i = 1;",
" if (2 < nStops - 1 && a > stopPoints[2]) i = 2;",
" if (3 < nStops - 1 && a > stopPoints[3]) i = 3;",
" if (4 < nStops - 1 && a > stopPoints[4]) i = 4;",
" if (5 < nStops - 1 && a > stopPoints[5]) i = 5;",
" if (6 < nStops - 1 && a > stopPoints[6]) i = 6;",
" if (7 < nStops - 1 && a > stopPoints[7]) i = 7;",
" if (8 < nStops - 1 && a > stopPoints[8]) i = 8;",
"",
" a = smoothstep(stopPoints[i], stopPoints[i+1], a);",
" fcolour = mix(stops[i], stops[i+1], a);",
"}"
]
circleFragmentShader :: B8.ByteString
circleFragmentShader :: ByteString
circleFragmentShader = String -> ByteString
B8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [
"#version 330 core",
"in vec2 coord;",
"out vec4 fcolour;",
"uniform vec2 center;",
"uniform float radius;",
"uniform vec4 stops[10];",
"uniform float stopPoints[10];",
"uniform int nStops;",
"",
"void main() {",
" float a = distance(coord, center)/radius;",
"",
" int i = 0;",
" if (1 < nStops - 1 && a > stopPoints[1]) i = 1;",
" if (2 < nStops - 1 && a > stopPoints[2]) i = 2;",
" if (3 < nStops - 1 && a > stopPoints[3]) i = 3;",
" if (4 < nStops - 1 && a > stopPoints[4]) i = 4;",
" if (5 < nStops - 1 && a > stopPoints[5]) i = 5;",
" if (6 < nStops - 1 && a > stopPoints[6]) i = 6;",
" if (7 < nStops - 1 && a > stopPoints[7]) i = 7;",
" if (8 < nStops - 1 && a > stopPoints[8]) i = 8;",
"",
" a = smoothstep(stopPoints[i], stopPoints[i+1], a);",
" fcolour = mix(stops[i], stops[i+1], a);",
"}"
]
conicFragmentShader :: B8.ByteString
conicFragmentShader :: ByteString
conicFragmentShader = String -> ByteString
B8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [
"#version 330 core",
"in vec2 coord;",
"out vec4 fcolour;",
"uniform vec2 center;",
"uniform float angle;",
"uniform vec4 stops[10];",
"uniform float stopPoints[10];",
"uniform int nStops;",
"",
"void main() {",
" vec2 v = coord - center;",
" float a = atan(v.x, -v.y) - angle;",
" float turn = 2*radians(180);",
" a = fract(a/turn);",
"",
" int i = 0;",
" if (1 < nStops - 1 && a > stopPoints[1]) i = 1;",
" if (2 < nStops - 1 && a > stopPoints[2]) i = 2;",
" if (3 < nStops - 1 && a > stopPoints[3]) i = 3;",
" if (4 < nStops - 1 && a > stopPoints[4]) i = 4;",
" if (5 < nStops - 1 && a > stopPoints[5]) i = 5;",
" if (6 < nStops - 1 && a > stopPoints[6]) i = 6;",
" if (7 < nStops - 1 && a > stopPoints[7]) i = 7;",
" if (8 < nStops - 1 && a > stopPoints[8]) i = 8;",
"",
" a = smoothstep(stopPoints[i], stopPoints[i+1], a);",
" fcolour = mix(stops[i], stops[i+1], a);",
"}"
]
renderBackgrounds :: (MonadIO m, MonadIO n) =>
n (Backgrounds Texture -> Rects -> M44 Float -> m ())
renderBackgrounds :: n (Backgrounds Texture -> Rects -> M44 Float -> m ())
renderBackgrounds = do
[Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ()
base <- ByteString
-> [String]
-> n ([Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ())
forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n) =>
ByteString
-> [String]
-> n ([Texture]
-> [Uniform m]
-> (a -> Rect)
-> (a -> Rect)
-> a
-> M44 Float
-> m ())
renderRectWith ByteString
baseFragmentShader ["colour"]
[Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ()
layer <- ByteString
-> [String]
-> n ([Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ())
forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n) =>
ByteString
-> [String]
-> n ([Texture]
-> [Uniform m]
-> (a -> Rect)
-> (a -> Rect)
-> a
-> M44 Float
-> m ())
renderRectWith ByteString
imageFragmentShader ["size", "pos"]
[Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ()
linear <- ByteString
-> [String]
-> n ([Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ())
forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n) =>
ByteString
-> [String]
-> n ([Texture]
-> [Uniform m]
-> (a -> Rect)
-> (a -> Rect)
-> a
-> M44 Float
-> m ())
renderRectWith ByteString
linearFragmentShader ["size", "angle",
"stops", "stopPoints", "nStops"]
[Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ()
ellipse <- ByteString
-> [String]
-> n ([Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ())
forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n) =>
ByteString
-> [String]
-> n ([Texture]
-> [Uniform m]
-> (a -> Rect)
-> (a -> Rect)
-> a
-> M44 Float
-> m ())
renderRectWith ByteString
radialFragmentShader ["size", "extent", "center",
"stops", "stopPoints", "nStops"]
[Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ()
circle <- ByteString
-> [String]
-> n ([Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ())
forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n) =>
ByteString
-> [String]
-> n ([Texture]
-> [Uniform m]
-> (a -> Rect)
-> (a -> Rect)
-> a
-> M44 Float
-> m ())
renderRectWith ByteString
circleFragmentShader ["center", "radius",
"stops", "stopPoints", "nStops"]
[Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ()
conic <- ByteString
-> [String]
-> n ([Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ())
forall (m :: * -> *) (n :: * -> *) a.
(MonadIO m, MonadIO n) =>
ByteString
-> [String]
-> n ([Texture]
-> [Uniform m]
-> (a -> Rect)
-> (a -> Rect)
-> a
-> M44 Float
-> m ())
renderRectWith ByteString
conicFragmentShader ["center", "angle",
"stops", "stopPoints", "nStops"]
(Backgrounds Texture -> Rects -> M44 Float -> m ())
-> n (Backgrounds Texture -> Rects -> M44 Float -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((Backgrounds Texture -> Rects -> M44 Float -> m ())
-> n (Backgrounds Texture -> Rects -> M44 Float -> m ()))
-> (Backgrounds Texture -> Rects -> M44 Float -> m ())
-> n (Backgrounds Texture -> Rects -> M44 Float -> m ())
forall a b. (a -> b) -> a -> b
$ \self :: Backgrounds Texture
self a :: Rects
a b :: M44 Float
b -> do
[Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ()
base [] [AlphaColour Float -> Uniform m
forall (m :: * -> *). MonadIO m => AlphaColour Float -> Uniform m
c (AlphaColour Float -> Uniform m) -> AlphaColour Float -> Uniform m
forall a b. (a -> b) -> a -> b
$ Backgrounds Texture -> AlphaColour Float
forall img. Backgrounds img -> AlphaColour Float
background Backgrounds Texture
self] ((Rects -> Rect) -> [Rects -> Rect] -> Rects -> Rect
forall c. c -> [c] -> c
headDef Rects -> Rect
borderBox ([Rects -> Rect] -> Rects -> Rect)
-> [Rects -> Rect] -> Rects -> Rect
forall a b. (a -> b) -> a -> b
$ Backgrounds Texture -> [Rects -> Rect]
forall img. Backgrounds img -> [Rects -> Rect]
clip Backgrounds Texture
self)
((Rects -> Rect) -> [Rects -> Rect] -> Rects -> Rect
forall c. c -> [c] -> c
headDef Rects -> Rect
paddingBox ([Rects -> Rect] -> Rects -> Rect)
-> [Rects -> Rect] -> Rects -> Rect
forall a b. (a -> b) -> a -> b
$ Backgrounds Texture -> [Rects -> Rect]
forall img. Backgrounds img -> [Rects -> Rect]
origin Backgrounds Texture
self) Rects
a M44 Float
b
let layers :: [(((((Pattern Texture, Rects -> Rect), Resize), Rects -> Rect),
(Length, Length)),
(Bool, Bool))]
layers = Backgrounds Texture -> [Pattern Texture]
forall img. Backgrounds img -> [Pattern img]
image Backgrounds Texture
self [Pattern Texture]
-> [Rects -> Rect] -> [(Pattern Texture, Rects -> Rect)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Backgrounds Texture -> [Rects -> Rect]
forall img. Backgrounds img -> [Rects -> Rect]
clip Backgrounds Texture
self [Rects -> Rect] -> [Rects -> Rect] -> [Rects -> Rect]
forall a. [a] -> [a] -> [a]
++ (Rects -> Rect) -> [Rects -> Rect]
forall a. a -> [a]
repeat Rects -> Rect
borderBox)
[(Pattern Texture, Rects -> Rect)]
-> [Resize] -> [((Pattern Texture, Rects -> Rect), Resize)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Backgrounds Texture -> [Resize]
forall img. Backgrounds img -> [Resize]
bgSize Backgrounds Texture
self [Resize] -> [Resize] -> [Resize]
forall a. [a] -> [a] -> [a]
++ Resize -> [Resize]
forall a. a -> [a]
repeat (Length -> Length -> Resize
Size Length
Auto Length
Auto))
[((Pattern Texture, Rects -> Rect), Resize)]
-> [Rects -> Rect]
-> [(((Pattern Texture, Rects -> Rect), Resize), Rects -> Rect)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Backgrounds Texture -> [Rects -> Rect]
forall img. Backgrounds img -> [Rects -> Rect]
origin Backgrounds Texture
self [Rects -> Rect] -> [Rects -> Rect] -> [Rects -> Rect]
forall a. [a] -> [a] -> [a]
++ (Rects -> Rect) -> [Rects -> Rect]
forall a. a -> [a]
repeat Rects -> Rect
paddingBox)
[(((Pattern Texture, Rects -> Rect), Resize), Rects -> Rect)]
-> [(Length, Length)]
-> [((((Pattern Texture, Rects -> Rect), Resize), Rects -> Rect),
(Length, Length))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Backgrounds Texture -> [(Length, Length)]
forall img. Backgrounds img -> [(Length, Length)]
bgPos Backgrounds Texture
self [(Length, Length)] -> [(Length, Length)] -> [(Length, Length)]
forall a. [a] -> [a] -> [a]
++ (Length, Length) -> [(Length, Length)]
forall a. a -> [a]
repeat (Float -> Length
Absolute 0, Float -> Length
Absolute 0))
[((((Pattern Texture, Rects -> Rect), Resize), Rects -> Rect),
(Length, Length))]
-> [(Bool, Bool)]
-> [(((((Pattern Texture, Rects -> Rect), Resize), Rects -> Rect),
(Length, Length)),
(Bool, Bool))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Backgrounds Texture -> [(Bool, Bool)]
forall img. Backgrounds img -> [(Bool, Bool)]
bgRepeat Backgrounds Texture
self [(Bool, Bool)] -> [(Bool, Bool)] -> [(Bool, Bool)]
forall a. [a] -> [a] -> [a]
++ (Bool, Bool) -> [(Bool, Bool)]
forall a. a -> [a]
repeat (Bool
True, Bool
True))
[()]
_<-[(((((Pattern Texture, Rects -> Rect), Resize), Rects -> Rect),
(Length, Length)),
(Bool, Bool))]
-> ((((((Pattern Texture, Rects -> Rect), Resize), Rects -> Rect),
(Length, Length)),
(Bool, Bool))
-> m ())
-> m [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(((((Pattern Texture, Rects -> Rect), Resize), Rects -> Rect),
(Length, Length)),
(Bool, Bool))]
layers (((((((Pattern Texture, Rects -> Rect), Resize), Rects -> Rect),
(Length, Length)),
(Bool, Bool))
-> m ())
-> m [()])
-> ((((((Pattern Texture, Rects -> Rect), Resize), Rects -> Rect),
(Length, Length)),
(Bool, Bool))
-> m ())
-> m [()]
forall a b. (a -> b) -> a -> b
$ \(((((pat0 :: Pattern Texture
pat0, clip0 :: Rects -> Rect
clip0), size0 :: Resize
size0), origin0 :: Rects -> Rect
origin0), pos0 :: (Length, Length)
pos0), repeat0 :: (Bool, Bool)
repeat0) ->
case Pattern Texture
pat0 of
None -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Img img0 :: Texture
img0 -> do
let sz :: (Float, Float)
sz = (Float, Float) -> (Float, Float) -> Resize -> (Float, Float)
resolveSize (Rect -> (Float, Float)
size (Rect -> (Float, Float)) -> Rect -> (Float, Float)
forall a b. (a -> b) -> a -> b
$ Rects -> Rect
clip0 Rects
a) (Texture -> (Float, Float)
texSize Texture
img0) Resize
size0
let pos' :: V2 Float
pos' = ((Float, Float) -> V2 Float
forall a. (a, a) -> V2 a
v2((Float, Float) -> V2 Float) -> (Float, Float) -> V2 Float
forall a b. (a -> b) -> a -> b
$(Length, Length) -> (Float, Float) -> (Float, Float)
l2f' (Length, Length)
pos0((Float, Float) -> (Float, Float))
-> (Float, Float) -> (Float, Float)
forall a b. (a -> b) -> a -> b
$Rect -> (Float, Float)
size(Rect -> (Float, Float)) -> Rect -> (Float, Float)
forall a b. (a -> b) -> a -> b
$Rects -> Rect
clip0 Rects
a) V2 Float -> V2 Float -> V2 Float
forall a. Num a => a -> a -> a
- ((Float, Float) -> V2 Float
forall a. (a, a) -> V2 a
v2((Float, Float) -> V2 Float) -> (Float, Float) -> V2 Float
forall a b. (a -> b) -> a -> b
$(Length, Length) -> (Float, Float) -> (Float, Float)
l2f' (Length, Length)
pos0 (Float, Float)
sz)
Texture -> (Bool, Bool) -> m ()
forall (m :: * -> *). MonadIO m => Texture -> (Bool, Bool) -> m ()
textureSetRepeat Texture
img0 (Bool, Bool)
repeat0
[Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ()
layer [Texture
img0] [V2 Float -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u (V2 Float -> Uniform m) -> V2 Float -> Uniform m
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> V2 Float
forall a. (a, a) -> V2 a
v2 (Float, Float)
sz, V2 Float -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u V2 Float
pos'] Rects -> Rect
clip0 Rects -> Rect
origin0 Rects
a M44 Float
b
Linear angle :: Float
angle stops :: [(AlphaColour Float, Length)]
stops -> let size' :: (Float, Float)
size' = Rect -> (Float, Float)
size (Rect -> (Float, Float)) -> Rect -> (Float, Float)
forall a b. (a -> b) -> a -> b
$ Rects -> Rect
clip0 Rects
a in [Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ()
linear [] [
V2 Float -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u (V2 Float -> Uniform m) -> V2 Float -> Uniform m
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> V2 Float
forall a. (a, a) -> V2 a
v2 ((Float, Float) -> V2 Float) -> (Float, Float) -> V2 Float
forall a b. (a -> b) -> a -> b
$ (Float, Float)
size', Float -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u Float
angle, Int -> [AlphaColour Float] -> Uniform m
forall (m :: * -> *).
MonadIO m =>
Int -> [AlphaColour Float] -> Uniform m
cs 10 ([AlphaColour Float] -> Uniform m)
-> [AlphaColour Float] -> Uniform m
forall a b. (a -> b) -> a -> b
$ ((AlphaColour Float, Length) -> AlphaColour Float)
-> [(AlphaColour Float, Length)] -> [AlphaColour Float]
forall a b. (a -> b) -> [a] -> [b]
map (AlphaColour Float, Length) -> AlphaColour Float
forall a b. (a, b) -> a
fst [(AlphaColour Float, Length)]
stops,
[Float] -> Uniform m
forall (m :: * -> *). MonadIO m => [Float] -> Uniform m
us ([Float] -> Uniform m) -> [Float] -> Uniform m
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> [Length] -> [Float]
ls2fs (Float, Float)
size' ([Length] -> [Float]) -> [Length] -> [Float]
forall a b. (a -> b) -> a -> b
$ ((AlphaColour Float, Length) -> Length)
-> [(AlphaColour Float, Length)] -> [Length]
forall a b. (a -> b) -> [a] -> [b]
map (AlphaColour Float, Length) -> Length
forall a b. (a, b) -> b
snd ([(AlphaColour Float, Length)] -> [Length])
-> [(AlphaColour Float, Length)] -> [Length]
forall a b. (a -> b) -> a -> b
$ Int
-> [(AlphaColour Float, Length)] -> [(AlphaColour Float, Length)]
forall a. Int -> [a] -> [a]
take 10 [(AlphaColour Float, Length)]
stops, Int -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u (Int -> Uniform m) -> Int -> Uniform m
forall a b. (a -> b) -> a -> b
$ [(AlphaColour Float, Length)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(AlphaColour Float, Length)]
stops
] Rects -> Rect
clip0 Rects -> Rect
origin0 Rects
a M44 Float
b
Radial Ellipse ext :: Extent
ext org :: (Length, Length)
org stops :: [(AlphaColour Float, Length)]
stops -> let sz :: (Float, Float)
sz@(_,h :: Float
h) = Rect -> (Float, Float)
size (Rect -> (Float, Float)) -> Rect -> (Float, Float)
forall a b. (a -> b) -> a -> b
$ Rects -> Rect
clip0 Rects
a in
let (org' :: (Float, Float)
org', ext' :: (Float, Float)
ext') = (Float, Float)
-> (Length, Length) -> Extent -> ((Float, Float), (Float, Float))
resolveEllipseExtent (Float, Float)
sz (Length, Length)
org Extent
ext in [Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ()
ellipse [] [
V2 Float -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u (V2 Float -> Uniform m) -> V2 Float -> Uniform m
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> V2 Float
forall a. (a, a) -> V2 a
v2 (Float, Float)
sz, V2 Float -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u (V2 Float -> Uniform m) -> V2 Float -> Uniform m
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> V2 Float
forall a. (a, a) -> V2 a
v2 (Float, Float)
ext', V2 Float -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u (V2 Float -> Uniform m) -> V2 Float -> Uniform m
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> V2 Float
forall a. (a, a) -> V2 a
v2 (Float, Float)
org', Int -> [AlphaColour Float] -> Uniform m
forall (m :: * -> *).
MonadIO m =>
Int -> [AlphaColour Float] -> Uniform m
cs 10 ([AlphaColour Float] -> Uniform m)
-> [AlphaColour Float] -> Uniform m
forall a b. (a -> b) -> a -> b
$ ((AlphaColour Float, Length) -> AlphaColour Float)
-> [(AlphaColour Float, Length)] -> [AlphaColour Float]
forall a b. (a -> b) -> [a] -> [b]
map (AlphaColour Float, Length) -> AlphaColour Float
forall a b. (a, b) -> a
fst [(AlphaColour Float, Length)]
stops,
[Float] -> Uniform m
forall (m :: * -> *). MonadIO m => [Float] -> Uniform m
us ([Float] -> Uniform m) -> [Float] -> Uniform m
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> [Length] -> [Float]
ls2fs (0,Float
hFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/2) ([Length] -> [Float]) -> [Length] -> [Float]
forall a b. (a -> b) -> a -> b
$ ((AlphaColour Float, Length) -> Length)
-> [(AlphaColour Float, Length)] -> [Length]
forall a b. (a -> b) -> [a] -> [b]
map (AlphaColour Float, Length) -> Length
forall a b. (a, b) -> b
snd ([(AlphaColour Float, Length)] -> [Length])
-> [(AlphaColour Float, Length)] -> [Length]
forall a b. (a -> b) -> a -> b
$ Int
-> [(AlphaColour Float, Length)] -> [(AlphaColour Float, Length)]
forall a. Int -> [a] -> [a]
take 10 [(AlphaColour Float, Length)]
stops, Int -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u (Int -> Uniform m) -> Int -> Uniform m
forall a b. (a -> b) -> a -> b
$ [(AlphaColour Float, Length)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(AlphaColour Float, Length)]
stops
] Rects -> Rect
clip0 Rects -> Rect
origin0 Rects
a M44 Float
b
Radial Circle ext :: Extent
ext org :: (Length, Length)
org stops :: [(AlphaColour Float, Length)]
stops -> let sz :: (Float, Float)
sz@(w :: Float
w,h :: Float
h) = Rect -> (Float, Float)
size (Rect -> (Float, Float)) -> Rect -> (Float, Float)
forall a b. (a -> b) -> a -> b
$ Rects -> Rect
clip0 Rects
a
in let (org' :: (Float, Float)
org', r :: Float
r) = (Float, Float)
-> (Length, Length) -> Extent -> ((Float, Float), Float)
resolveCircleExtent (Float, Float)
sz (Length, Length)
org Extent
ext in [Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ()
circle [] [
V2 Float -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u (V2 Float -> Uniform m) -> V2 Float -> Uniform m
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> V2 Float
forall a. (a, a) -> V2 a
v2 (Float, Float)
org', Float -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u Float
r, Int -> [AlphaColour Float] -> Uniform m
forall (m :: * -> *).
MonadIO m =>
Int -> [AlphaColour Float] -> Uniform m
cs 10 ([AlphaColour Float] -> Uniform m)
-> [AlphaColour Float] -> Uniform m
forall a b. (a -> b) -> a -> b
$ ((AlphaColour Float, Length) -> AlphaColour Float)
-> [(AlphaColour Float, Length)] -> [AlphaColour Float]
forall a b. (a -> b) -> [a] -> [b]
map (AlphaColour Float, Length) -> AlphaColour Float
forall a b. (a, b) -> a
fst [(AlphaColour Float, Length)]
stops,
[Float] -> Uniform m
forall (m :: * -> *). MonadIO m => [Float] -> Uniform m
us ([Float] -> Uniform m) -> [Float] -> Uniform m
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> [Length] -> [Float]
ls2fs (0,Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
w Float
hFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/2) ([Length] -> [Float]) -> [Length] -> [Float]
forall a b. (a -> b) -> a -> b
$ ((AlphaColour Float, Length) -> Length)
-> [(AlphaColour Float, Length)] -> [Length]
forall a b. (a -> b) -> [a] -> [b]
map (AlphaColour Float, Length) -> Length
forall a b. (a, b) -> b
snd ([(AlphaColour Float, Length)] -> [Length])
-> [(AlphaColour Float, Length)] -> [Length]
forall a b. (a -> b) -> a -> b
$ Int
-> [(AlphaColour Float, Length)] -> [(AlphaColour Float, Length)]
forall a. Int -> [a] -> [a]
take 10 [(AlphaColour Float, Length)]
stops,
Int -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u (Int -> Uniform m) -> Int -> Uniform m
forall a b. (a -> b) -> a -> b
$ [(AlphaColour Float, Length)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(AlphaColour Float, Length)]
stops
] Rects -> Rect
clip0 Rects -> Rect
origin0 Rects
a M44 Float
b
Conical angle :: Float
angle org :: (Length, Length)
org stops :: [(AlphaColour Float, Length)]
stops -> let sz :: (Float, Float)
sz = Rect -> (Float, Float)
size (Rect -> (Float, Float)) -> Rect -> (Float, Float)
forall a b. (a -> b) -> a -> b
$ Rects -> Rect
clip0 Rects
a in [Texture]
-> [Uniform m]
-> (Rects -> Rect)
-> (Rects -> Rect)
-> Rects
-> M44 Float
-> m ()
conic [] [
V2 Float -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u (V2 Float -> Uniform m) -> V2 Float -> Uniform m
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> V2 Float
forall a. (a, a) -> V2 a
v2 ((Float, Float) -> V2 Float) -> (Float, Float) -> V2 Float
forall a b. (a -> b) -> a -> b
$ (Length, Length) -> (Float, Float) -> (Float, Float)
l2f' (Length, Length)
org (Float, Float)
sz, Float -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u Float
angle, Int -> [AlphaColour Float] -> Uniform m
forall (m :: * -> *).
MonadIO m =>
Int -> [AlphaColour Float] -> Uniform m
cs 10 ([AlphaColour Float] -> Uniform m)
-> [AlphaColour Float] -> Uniform m
forall a b. (a -> b) -> a -> b
$ ((AlphaColour Float, Length) -> AlphaColour Float)
-> [(AlphaColour Float, Length)] -> [AlphaColour Float]
forall a b. (a -> b) -> [a] -> [b]
map (AlphaColour Float, Length) -> AlphaColour Float
forall a b. (a, b) -> a
fst [(AlphaColour Float, Length)]
stops,
[Float] -> Uniform m
forall (m :: * -> *). MonadIO m => [Float] -> Uniform m
us ([Float] -> Uniform m) -> [Float] -> Uniform m
forall a b. (a -> b) -> a -> b
$ (Float, Float) -> [Length] -> [Float]
ls2fs (0,2Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
forall a. Floating a => a
pi) ([Length] -> [Float]) -> [Length] -> [Float]
forall a b. (a -> b) -> a -> b
$ ((AlphaColour Float, Length) -> Length)
-> [(AlphaColour Float, Length)] -> [Length]
forall a b. (a -> b) -> [a] -> [b]
map (AlphaColour Float, Length) -> Length
forall a b. (a, b) -> b
snd ([(AlphaColour Float, Length)] -> [Length])
-> [(AlphaColour Float, Length)] -> [Length]
forall a b. (a -> b) -> a -> b
$ Int
-> [(AlphaColour Float, Length)] -> [(AlphaColour Float, Length)]
forall a. Int -> [a] -> [a]
take 10 [(AlphaColour Float, Length)]
stops, Int -> Uniform m
forall (m :: * -> *) a.
(MonadIO m, UniformValue a) =>
a -> Uniform m
u (Int -> Uniform m) -> Int -> Uniform m
forall a b. (a -> b) -> a -> b
$ [(AlphaColour Float, Length)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(AlphaColour Float, Length)]
stops
] Rects -> Rect
clip0 Rects -> Rect
origin0 Rects
a M44 Float
b
() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
headDef :: c -> [c] -> c
headDef :: c -> [c] -> c
headDef def :: c
def = c -> Maybe c -> c
forall a. a -> Maybe a -> a
fromMaybe c
def (Maybe c -> c) -> ([c] -> Maybe c) -> [c] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [c] -> Maybe c
forall a. [a] -> Maybe a
listToMaybe
v2 :: (a, a) -> V2 a
v2 :: (a, a) -> V2 a
v2 = (a -> a -> V2 a) -> (a, a) -> V2 a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> V2 a
forall a. a -> a -> V2 a
V2
ls2fs :: (Float, Float) -> [Length] -> [Float]
ls2fs :: (Float, Float) -> [Length] -> [Float]
ls2fs (_,h :: Float
h) ls :: [Length]
ls = Float -> [Length] -> [Float]
resolveAutos 0 ([Length] -> [Float]) -> [Length] -> [Float]
forall a b. (a -> b) -> a -> b
$ Bool -> Float -> [Length] -> [Length]
inner Bool
True 0 [Length]
ls
where
inner :: Bool -> Float -> [Length] -> [Length]
inner True _ (Auto:ls' :: [Length]
ls') = Float -> Length
Scale 0Length -> [Length] -> [Length]
forall a. a -> [a] -> [a]
:Bool -> Float -> [Length] -> [Length]
inner Bool
False 0 [Length]
ls'
inner _ _ [Auto] = [Float -> Length
Scale 1]
inner _ prev :: Float
prev (Scale x :: Float
x:ls' :: [Length]
ls') | Float
x Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
prev = Float -> Length
Scale Float
prevLength -> [Length] -> [Length]
forall a. a -> [a] -> [a]
:Bool -> Float -> [Length] -> [Length]
inner Bool
False Float
prev [Length]
ls'
inner _ prev :: Float
prev (Absolute x :: Float
x:ls' :: [Length]
ls') | Float
xFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
h Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
prev = Float -> Length
Scale Float
prevLength -> [Length] -> [Length]
forall a. a -> [a] -> [a]
:Bool -> Float -> [Length] -> [Length]
inner Bool
False Float
prev [Length]
ls'
inner _ _ (Scale x :: Float
x:ls' :: [Length]
ls') = Float -> Length
Scale Float
xLength -> [Length] -> [Length]
forall a. a -> [a] -> [a]
:Bool -> Float -> [Length] -> [Length]
inner Bool
False Float
x [Length]
ls'
inner _ _ (Absolute x :: Float
x:ls' :: [Length]
ls') = Float -> Length
Absolute Float
xLength -> [Length] -> [Length]
forall a. a -> [a] -> [a]
:Bool -> Float -> [Length] -> [Length]
inner Bool
False (Float
xFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
h) [Length]
ls'
inner _ prev :: Float
prev (Auto:ls' :: [Length]
ls') = Length
AutoLength -> [Length] -> [Length]
forall a. a -> [a] -> [a]
:Bool -> Float -> [Length] -> [Length]
inner Bool
False Float
prev [Length]
ls'
inner _ _ [] = []
resolveAutos :: Float -> [Length] -> [Float]
resolveAutos :: Float -> [Length] -> [Float]
resolveAutos _ (Scale x :: Float
x:ls' :: [Length]
ls') = Float
xFloat -> [Float] -> [Float]
forall a. a -> [a] -> [a]
:Float -> [Length] -> [Float]
resolveAutos Float
x [Length]
ls'
resolveAutos _ (Absolute x :: Float
x:ls' :: [Length]
ls') = (Float
xFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
h)Float -> [Float] -> [Float]
forall a. a -> [a] -> [a]
:Float -> [Length] -> [Float]
resolveAutos (Float
xFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
h) [Length]
ls'
resolveAutos _ [] = []
resolveAutos prev :: Float
prev ls0 :: [Length]
ls0 = [Float
prev Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float
forall a. Enum a => a -> a
succ Float
iFloat -> Float -> Float
forall a. Num a => a -> a -> a
*Float
grad | Float
i <- [0..Float
n Float -> Float -> Float
forall a. Num a => a -> a -> a
- 1]] [Float] -> [Float] -> [Float]
forall a. [a] -> [a] -> [a]
++ [Float]
fs
where
(autos :: [Length]
autos, ls' :: [Length]
ls') = (Length -> Bool) -> [Length] -> ([Length], [Length])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Length -> Length -> Bool
forall a. Eq a => a -> a -> Bool
==Length
Auto) [Length]
ls0
n :: Float
n = Int -> Float
forall a. Enum a => Int -> a
toEnum (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ [Length] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Length]
autos
fs :: [Float]
fs = Float -> [Length] -> [Float]
resolveAutos 0 [Length]
ls'
next :: Float
next | (x :: Float
x:_) <- [Float]
fs = Float
x
| Bool
otherwise = 1
grad :: Float
grad = (Float
next Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
prev)Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/(Float
n Float -> Float -> Float
forall a. Num a => a -> a -> a
+ 1)
l2f :: Length -> Float -> Float
l2f :: Length -> Float -> Float
l2f Auto x :: Float
x = Float
xFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/2
l2f (Scale x :: Float
x) y :: Float
y = Float
xFloat -> Float -> Float
forall a. Num a => a -> a -> a
*Float
y
l2f (Absolute x :: Float
x) _ = Float
x
l2f' :: (Length, Length) -> (Float, Float) -> (Float, Float)
l2f' :: (Length, Length) -> (Float, Float) -> (Float, Float)
l2f' (x :: Length
x,y :: Length
y) (w :: Float
w,h :: Float
h) = (Length -> Float -> Float
l2f Length
x Float
w, Length -> Float -> Float
l2f Length
y Float
h)
resolveEllipseExtent :: (Float, Float) -> (Length, Length) -> Extent ->
((Float, Float), (Float, Float))
resolveEllipseExtent :: (Float, Float)
-> (Length, Length) -> Extent -> ((Float, Float), (Float, Float))
resolveEllipseExtent sz :: (Float, Float)
sz@(x' :: Float
x',y' :: Float
y') pos :: (Length, Length)
pos ext :: Extent
ext = ((Float
x, Float
y), Extent -> (Float, Float)
inner Extent
ext)
where
(x :: Float
x,y :: Float
y) = (Length, Length) -> (Float, Float) -> (Float, Float)
l2f' (Length, Length)
pos (Float, Float)
sz
horiz :: [Float]
horiz = [Float
x, Float
x' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x]
vert :: [Float]
vert = [Float
y, Float
y' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y]
inner :: Extent -> (Float, Float)
inner (Extent s :: Length
s t :: Length
t) = (Length -> Float -> Float
l2f Length
s Float
x, Length -> Float -> Float
l2f Length
t Float
y)
inner ClosestCorner = ([Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Float]
horiz Float -> Float -> Float
forall a. Num a => a -> a -> a
* 2, [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Float]
vert Float -> Float -> Float
forall a. Num a => a -> a -> a
* 2)
inner ClosestSide = ([Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Float]
horiz Float -> Float -> Float
forall a. Num a => a -> a -> a
* 2, [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Float]
vert Float -> Float -> Float
forall a. Num a => a -> a -> a
* 2)
inner FarthestCorner = ([Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
horiz Float -> Float -> Float
forall a. Num a => a -> a -> a
* 2, [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
vert Float -> Float -> Float
forall a. Num a => a -> a -> a
* 2)
inner FarthestSide = ([Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
horiz Float -> Float -> Float
forall a. Num a => a -> a -> a
* 2, [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
vert Float -> Float -> Float
forall a. Num a => a -> a -> a
* 2)
resolveCircleExtent :: (Float, Float) -> (Length, Length) -> Extent ->
((Float, Float), Float)
resolveCircleExtent :: (Float, Float)
-> (Length, Length) -> Extent -> ((Float, Float), Float)
resolveCircleExtent sz :: (Float, Float)
sz@(x' :: Float
x',y' :: Float
y') pos :: (Length, Length)
pos ext :: Extent
ext = ((Float
x, Float
y), Extent -> Float
inner Extent
ext)
where
(x :: Float
x,y :: Float
y) = (Length, Length) -> (Float, Float) -> (Float, Float)
l2f' (Length, Length)
pos (Float, Float)
sz
sides :: [Float]
sides = [Float
x, Float
x' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x, Float
y, Float
y' Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y]
corners :: [Float]
corners = [Float -> Float -> Float
forall a. Floating a => a -> a -> a
hypot Float
x Float
y, Float -> Float -> Float
forall a. Floating a => a -> a -> a
hypot Float
x (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$ Float
y'Float -> Float -> Float
forall a. Num a => a -> a -> a
-Float
y, Float -> Float -> Float
forall a. Floating a => a -> a -> a
hypot Float
y (Float -> Float) -> Float -> Float
forall a b. (a -> b) -> a -> b
$ Float
x'Float -> Float -> Float
forall a. Num a => a -> a -> a
-Float
x, Float -> Float -> Float
forall a. Floating a => a -> a -> a
hypot (Float
x'Float -> Float -> Float
forall a. Num a => a -> a -> a
-Float
x) (Float
y'Float -> Float -> Float
forall a. Num a => a -> a -> a
-Float
y)]
hypot :: a -> a -> a
hypot a :: a
a b :: a
b = a -> a
forall a. Floating a => a -> a
sqrt (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
aa -> a -> a
forall a. Num a => a -> a -> a
*a
a a -> a -> a
forall a. Num a => a -> a -> a
+ a
ba -> a -> a
forall a. Num a => a -> a -> a
*a
b
inner :: Extent -> Float
inner (Extent a :: Length
a _) = Length -> Float -> Float
l2f Length
a Float
y
inner ClosestCorner = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Float]
corners
inner ClosestSide = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Float]
sides
inner FarthestCorner = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
corners
inner FarthestSide = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
sides