~alcinnz/CatTrap

ref: 64892909facd4a1382483b5bf0dba51e49d44c80 CatTrap/Graphics/Layout/Box.hs -rw-r--r-- 3.7 KiB
64892909 — Adrian Cochrane Simplify natwidth generic logic. 1 year, 7 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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
{-# LANGUAGE RecordWildCards #-}
module Graphics.Layout.Box(Border(..), mapX, mapY,
        Size(..), mapSizeX, mapSizeY,
        PaddedBox(..), zeroBox, lengthBox, mapX', mapY',
        width, height, minWidth, minHeight, maxWidth, maxHeight,
        Length(..), mapAuto, lowerLength, Zero(..), CastDouble(..)) where

data Border m n = Border {
    top :: m, bottom :: m, left :: n, right :: n
}
mapX :: (n -> nn) -> Border m n -> Border m nn
mapY :: (m -> mm) -> Border m n -> Border mm n
mapX cb self = self { left = cb $ left self, right = cb $ right self }
mapY cb self = self { top = cb $ top self, bottom = cb $ bottom self }

data Size m n = Size {inline :: n, block :: m} deriving (Eq, Show)
mapSizeY cb self = Size (inline self) (cb $ block self)
mapSizeX cb self = Size (cb $ inline self) (block self)

data PaddedBox m n = PaddedBox {
    min :: Size m n,
    max :: Size m n,
    size :: Size m n,
    padding :: Border m n,
    border :: Border m n,
    margin :: Border m n
}
zeroBox :: PaddedBox Double Double
zeroBox = PaddedBox {
    min = Size 0 0,
    max = Size 0 0,
    size = Size 0 0,
    padding = Border 0 0 0 0,
    border = Border 0 0 0 0,
    margin = Border 0 0 0 0
  }
lengthBox = PaddedBox {
    min = Size Auto Auto,
    max = Size Auto Auto,
    size = Size Auto Auto,
    padding = Border zero zero zero zero,
    border = Border zero zero zero zero,
    margin = Border zero zero zero zero
  }

mapX' :: (n -> nn) -> PaddedBox m n -> PaddedBox m nn
mapX' cb PaddedBox {..} = PaddedBox {
    min = Size (cb $ inline min) (block min),
    size = Size (cb $ inline size) (block size),
    max = Size (cb $ inline max) (block max),
    padding = mapX cb padding,
    border = mapX cb border,
    margin = mapX cb margin
  }
mapY' :: (m -> mm) -> PaddedBox m n -> PaddedBox mm n
mapY' cb PaddedBox {..} = PaddedBox {
    min = Size (inline min) (cb $ block min),
    size = Size (inline size) (cb $ block size),
    max = Size (inline max) (cb $ block max),
    padding = mapY cb padding,
    border = mapY cb border,
    margin = mapY cb margin
  }

width PaddedBox {..} = left margin + left border + left padding +
    inline size + right padding + right border + right margin
height PaddedBox {..} = top margin + top border + top padding +
    block size + bottom padding + bottom border + bottom margin
minWidth PaddedBox {..} = left margin + left border + left padding +
    inline min + right padding + right border + right margin
minHeight PaddedBox {..} = top margin + top border + top padding +
    block min + bottom padding + bottom border + bottom margin
maxWidth PaddedBox {..} = left margin + left border + left padding +
    inline max + right padding + right border + right margin
maxHeight PaddedBox {..} = top margin + top border + top padding +
    block max + bottom padding + bottom border + bottom margin

data Length = Pixels Double | Percent Double | Auto | Preferred | Min deriving Eq

lowerLength :: Double -> Length -> Double
lowerLength _ (Pixels x) = x
lowerLength outerwidth (Percent x) = x * outerwidth
lowerLength _ _ = 0

mapAuto x Auto = Pixels x
mapAuto x Preferred = Pixels x
mapAuto x Min = Pixels x
mapAuto _ x = x

class Zero a where
    zero :: a

instance Zero Double where zero = 0
instance Zero Length where zero = Pixels 0
instance (Zero m, Zero n) => Zero (PaddedBox m n) where
    zero = PaddedBox {
        min = Size zero zero,
        max = Size zero zero,
        size = Size zero zero,
    padding = Border zero zero zero zero,
    border = Border zero zero zero zero,
    margin = Border zero zero zero zero
    }

class CastDouble a where
    fromDouble :: Double -> a

instance CastDouble Double where fromDouble = id
instance CastDouble Length where fromDouble = Pixels