1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), Pattern(..),
Resize(..), Length(..), resolveSize, renderBackgrounds) where
import Graphics.Rendering.Rect.CSS.Backgrounds
import Graphics.Rendering.Rect.Types
import Graphics.Rendering.Rect.Image (Texture(texSize))
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.pack $ unlines [
"#version 330 core",
"out vec4 fcolour;",
"uniform vec4 colour;",
"void main() { fcolour = colour; }"
]
imageFragmentShader = B8.pack $ unlines [
"#version 330 core",
"in vec2 coord;",
"out vec4 fcolour;",
"uniform sampler2D image;",
"uniform vec2 size;",
"void main() { fcolour = texture(image, coord/size); }"
]
linearFragmentShader = B8.pack $ unlines [
"#version 330 core",
"in vec2 coord;",
"out vec4 fcolour;",
"uniform vec2 size;",
"uniform vec4 start;",
"uniform vec4 end;",
"void main() { fcolour = mix(start, end, coord.y/size.y); }"
]
renderBackgrounds :: (MonadIO m, MonadIO n) =>
n (Backgrounds Texture -> Rects -> M44 Float -> m ())
renderBackgrounds = do
base <- renderRectWith baseFragmentShader ["colour"]
layer <- renderRectWith imageFragmentShader ["size"]
linear <- renderRectWith linearFragmentShader ["size", "start", "end"]
return $ \self a b -> do
base [] [c $ background self] (headDef borderBox $ clip self) a b
let layers = image self `zip` (clip self ++ repeat borderBox)
`zip` (bgSize self ++ repeat (Size Auto Auto))
forM layers $ \((pat0, clip0), size0) -> case pat0 of
None -> return ()
Img img0 -> layer [img0] [
u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0
] clip0 a b
Linear start end -> linear [] [
u $ v2 $ size $ clip0 a, c start, c end
] clip0 a b
return ()
headDef def = fromMaybe def . listToMaybe
v2 = uncurry V2