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
|
{-# 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 :: !Double
, 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 widgets) = sum (map (\(Widget w) -> minSize w) widgets) + borderH p + 2*bw + borderH m
where
m = margin config
bw = borderWidth config
p = padding config
weight (Border config _) = borderWeight config
layout (Border config _) (BorderState widgetStates) width height = BorderState $ layoutWidgets widgetStates x y width' height'
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 = do
drawBorder config 0 0 w h
clip
renderWidgets widgetStates
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 = 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 widgets = Widget $ Border config widgets
|
