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
|
{-# LANGUAGE TypeFamilies #-}
module Phi.Border ( BorderWidth(..)
, simpleBorderWidth
, borderH
, borderV
, BorderConfig(..)
, defaultBorderConfig
, drawBorder
, roundRectangle
, 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
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 BorderState = BorderState [WidgetState] deriving Show
data BorderConfig = BorderConfig { margin :: !BorderWidth
, borderWidth :: !Int
, padding :: !BorderWidth
, borderColor :: !Color
, backgroundColor :: !Color
, cornerRadius :: !Int
, borderWeight :: !Float
} deriving Show
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 = Border BorderConfig [Widget] deriving Show
instance WidgetClass Border where
type WidgetData Border = BorderState
initWidget (Border _ widgets) phi disp = liftM BorderState $ mapM (createWidgetState phi disp) widgets
minSize (Border config _) (BorderState widgetStates) height screen =
case True of
_ | childSize == 0 -> 0
| otherwise -> max (borderH m+2*(bw+cr)) (childSize + borderH p + 2*bw + borderH m)
where
childSize = sum $ map (\(WidgetState {stateWidget = w, statePrivateData = priv}) -> minSize w priv height' screen) widgetStates
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 _) (BorderState widgetStates) width height screen = case True of
_ | width' > 0 -> BorderState $ layoutWidgets widgetStates x y width' height' screen
| otherwise -> BorderState widgetStates
where
m = margin config
bw = borderWidth config
p = padding config
x = borderLeft m + bw + borderLeft p
y = borderTop m + bw + borderTop p
width' = width - borderH m - 2*bw - borderH p
height' = height - borderV m - 2*bw - borderV p
render (Border config _) (BorderState widgetStates) w h screen = when (w > borderH m - 2*bw - borderH p) $ do
drawBorder config 0 0 w h
clip
renderWidgets widgetStates screen
where
m = margin config
bw = borderWidth config
p = padding config
handleMessage _ (BorderState widgetStates) m = BorderState $ handleMessageWidgets m widgetStates
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 :: BorderConfig -> [Widget] -> Widget
border config = Widget . Border config
|
