~alcinnz/Mondrian

ref: 396e7db5dd94429a8522e091d806bf80f25dbc55 Mondrian/lib/Graphics/Rendering/Rect.hs -rw-r--r-- 1.7 KiB
396e7db5 — Adrian Cochrane Implement conic gradients, support elliptical extents. 1 year, 6 months ago
                                                                                
10e61b66 Adrian Cochrane
483226a3 Adrian Cochrane
94547420 Adrian Cochrane
eba0f9a2 Adrian Cochrane
10e61b66 Adrian Cochrane
eba0f9a2 Adrian Cochrane
94547420 Adrian Cochrane
10e61b66 Adrian Cochrane
94547420 Adrian Cochrane
10e61b66 Adrian Cochrane
a08fe055 Adrian Cochrane
10e61b66 Adrian Cochrane
94547420 Adrian Cochrane
10e61b66 Adrian Cochrane
94547420 Adrian Cochrane
1adb7b35 Adrian Cochrane
94547420 Adrian Cochrane
1adb7b35 Adrian Cochrane
e8160393 Adrian Cochrane
ec7d175b Adrian Cochrane
396e7db5 Adrian Cochrane
94547420 Adrian Cochrane
1adb7b35 Adrian Cochrane
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
module Graphics.Rendering.Rect(Rect(..), Rects(..), shrink, shrink1, renderRects,
    RectStyle(..), colour,
    Backgrounds(..), Pattern(..), Resize(..), Length(..), RadialShape(..),
    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 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
    return $ \style rects mat -> do
        bg (backgrounds 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]