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
module Graphics.Rendering.Rect(Rect(..), Rects(..), shrink, shrink1, renderRects,
RectStyle(..), colour, border,
Backgrounds(..), Pattern(..), Resize(..), Length(..), RadialShape(..),
Border(..), BorderStyle(..), topColour, rightColour, bottomColour, leftColour,
Atlas, buildAtlas, atlasFromStyles, Texture, styleResolveImages) where
import Graphics.Rendering.Rect.CSS
import Graphics.Rendering.Rect.Backgrounds
import Graphics.Rendering.Rect.Types
import Graphics.Rendering.Rect.Image
import Graphics.Rendering.Rect.Border
import Linear (M44)
import Control.Monad.IO.Class (MonadIO)
import Codec.Picture (DynamicImage)
import Data.Text (Text)
import Data.List (nub)
shrink :: Rect -> Float -> Float -> Float -> Float -> Rect
shrink self dLeft dTop dRight dBottom =
Rect (left self + dLeft) (top self + dTop)
(right self - dRight) (bottom self - dBottom)
shrink1 :: Rect -> Float -> Rect
shrink1 self d = shrink self d d d d
renderRects :: (MonadIO m, MonadIO n) =>
n (RectStyle Texture -> Rects -> M44 Float -> m ())
renderRects = do
bg <- renderBackgrounds
frame <- renderBorder
return $ \style rects mat -> do
bg (backgrounds style) rects mat
frame (border style) rects mat
styleResolveImages :: Atlas -> RectStyle Text -> RectStyle Texture
styleResolveImages atlas self =
let textures = map atlasLookup' $ image $ backgrounds self
in self { backgrounds = (backgrounds self) { image = textures } }
where
atlasLookup' None = None
atlasLookup' (Img path) = Img $ atlasLookup path atlas
atlasLookup' (Linear a b) = Linear a b
atlasLookup' (Radial a b cc d) = Radial a b cc d
atlasLookup' (Conical a b cc) = Conical a b cc
atlasFromStyles :: MonadIO m =>
(Text -> IO DynamicImage) -> [RectStyle Text] -> m Atlas
atlasFromStyles cb styles =
buildAtlas cb $ nub [path | s <- styles, Img path <- image $ backgrounds s]