~alcinnz/Mondrian

ref: 7564554b3527f7e220c09c24cc9f8035d3f196b0 Mondrian/lib/Graphics/Rendering/Rect.hs -rw-r--r-- 1.9 KiB
7564554b — Adrian Cochrane Commit border renderer, make them trapazoidal. 1 year, 5 months ago
                                                                                
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]