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
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
{-# 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 Control.Monad.State.Strict
import Data.Maybe
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 s c = (Widget w s c) => Border !BorderConfig !w
data BorderCache w s c = (Widget w s c) => BorderCache !c
instance Eq s => Widget (Border w s c) s (BorderCache w s c) where
initWidget (Border _ w) = initWidget w
initCache (Border _ w) = BorderCache $ initCache w
minSize (Border config w) s 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 s 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
render (Border config w) s x y width height screen = case () of
_ | (width > borderH m - 2*bw - borderH p) -> do
border <- liftIO $ createImageSurface FormatARGB32 width height
renderWith border $ do
setOperator OperatorClear
paint
setOperator OperatorOver
drawBorder config 0 0 width height
BorderCache c <- get
(surfaces, c') <- liftIO $ flip runStateT c $ render w s (x+dx) (y+dy) width' height' screen
put $ BorderCache c'
let surfaces' = (True, 0, Nothing):(map (\(updated, SurfaceSlice x surf) -> (updated, x+dx, Just surf)) surfaces)++[(True, width-rightWidth, Nothing)]
surfacesWidths = zipWith (\(updated, x, surf) (_, x', _) -> (updated, x, x'-x, surf)) surfaces' (tail surfaces' ++ [(False, width, Nothing)])
forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do
surf' <- liftIO $ createImageSurface FormatARGB32 surfWidth height
renderWith surf' $ do
setOperator OperatorClear
paint
setOperator OperatorOver
save
translate (fromIntegral (-x)) 0
withPatternForSurface border setSource
paint
restore
case surf of
Just surface -> do
translate 0 (fromIntegral dy)
withPatternForSurface surface setSource
paint
Nothing -> return ()
return (updated, SurfaceSlice x surf')
| otherwise -> do
surface <- liftIO $ createImageSurface FormatARGB32 width height
return [(True, SurfaceSlice 0 surface)]
where
m = margin config
bw = borderWidth config
p = padding config
leftWidth = borderLeft m + bw + borderLeft p
rightWidth = borderRight m + bw + borderRight p
dx = leftWidth
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 s c) => BorderConfig -> w -> Border w s c
border = Border
|
