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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, ExistentialQuantification, FlexibleInstances #-}
module Phi.Border ( BorderWidth(..)
, simpleBorderWidth
, borderH
, borderV
, BorderConfig(..)
, defaultBorderConfig
, drawBorder
, roundRectangle
, Border
, border
) where
import Phi.Types
import Phi.Widget
import Control.Monad
import Graphics.Rendering.Cairo
data BorderWidth = BorderWidth { borderTop :: !Int
, borderRight :: !Int
, borderBottom :: !Int
, borderLeft :: !Int
} deriving (Show, Eq)
simpleBorderWidth :: Int -> BorderWidth
simpleBorderWidth w = BorderWidth w w w w
borderH :: BorderWidth -> Int
borderH bw = borderLeft bw + borderRight bw
borderV :: BorderWidth -> Int
borderV bw = borderTop bw + borderBottom bw
data BorderConfig = BorderConfig { margin :: !BorderWidth
, borderWidth :: !Int
, padding :: !BorderWidth
, borderColor :: !Color
, backgroundColor :: !Color
, cornerRadius :: !Int
, borderWeight :: !Float
} deriving (Show, Eq)
defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
, borderWidth = 1
, padding = simpleBorderWidth 1
, borderColor = (0, 0, 0, 1)
, backgroundColor = (0, 0, 0, 0)
, cornerRadius = 0
, borderWeight = 1
}
data Border w d = (Widget w d) => Border !BorderConfig !w
deriving instance Show (Border w d)
deriving instance Eq (Border w d)
instance Eq d => Widget (Border w d) d where
initWidget (Border _ w) = initWidget w
minSize (Border config w) d height screen =
case True of
_ | childSize == 0 -> 0
| otherwise -> max (borderH m+2*(bw+cr)) (childSize + borderH p + 2*bw + borderH m)
where
childSize = minSize w d height' screen
m = margin config
bw = borderWidth config
p = padding config
cr = cornerRadius config
height' = height - borderV m - 2*bw - borderV p
weight (Border config _) = borderWeight config
layout (Border config w) d width height screen = case True of
_ | width' > 0 -> layout w d width' height' screen
| otherwise -> d
where
m = margin config
bw = borderWidth config
p = padding config
width' = width - borderH m - 2*bw - borderH p
height' = height - borderV m - 2*bw - borderV p
render (Border config w) d x y width height screen = when (width > borderH m - 2*bw - borderH p) $ do
drawBorder config 0 0 width height
clip
translate (fromIntegral dx) (fromIntegral dy)
render w d (x+dx) (y+dy) width' height' screen
return ()
where
m = margin config
bw = borderWidth config
p = padding config
dx = borderLeft m + bw + borderLeft p
dy = borderTop m + bw + borderTop p
width' = width - borderH m - 2*bw - borderH p
height' = height - borderV m - 2*bw - borderV p
handleMessage (Border _ w) = handleMessage w
drawBorder :: BorderConfig -> Int -> Int -> Int -> Int -> Render ()
drawBorder config dx dy w h = do
roundRectangle x y width height radius
save
setSourceRGBA fr fg fb fa
fillPreserve
setSourceRGBA br bg bb ba
setLineWidth $ fromIntegral bw
strokePreserve
restore
where
m = margin config
bw = borderWidth config
p = padding config
radius = fromIntegral $ cornerRadius config
x = (fromIntegral dx) + (fromIntegral $ borderLeft m) + (fromIntegral bw)/2
y = (fromIntegral dy) + (fromIntegral $ borderTop m) + (fromIntegral bw)/2
width = fromIntegral $ w - borderH m - bw
height = fromIntegral $ h - borderV m - bw
(br, bg, bb, ba) = borderColor config
(fr, fg, fb, fa) = backgroundColor config
roundRectangle :: Double -> Double -> Double -> Double -> Double -> Render ()
roundRectangle x y width height radius = do
newPath
arc (x + width - radius) (y + radius) radius (-pi/2) 0
arc (x + width - radius) (y + height - radius) radius 0 (pi/2)
arc (x + radius) (y + height - radius) radius (pi/2) pi
arc (x + radius) (y + radius) radius pi (pi*3/2)
closePath
border :: (Widget w d) => BorderConfig -> w -> Border w d
border = Border
|
