Matthias Schiffer
028c4243a8
Extremely hacky at the moment, for now the caching isn't used at all...
138 lines
4.8 KiB
Haskell
138 lines
4.8 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
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, 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 BorderState = BorderState ![WidgetState] deriving Eq
|
|
|
|
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 = Border !BorderConfig ![Widget] deriving (Show, Eq)
|
|
|
|
instance WidgetClass Border BorderState where
|
|
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) x y w h screen = when (w > borderH m - 2*bw - borderH p) $ do
|
|
drawBorder config 0 0 w h
|
|
clip
|
|
renderWidgets widgetStates screen x y
|
|
return ()
|
|
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
|