{-# 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 layout (Border config w) s width height screen = case True of _ | width' > 0 -> layout w s width' height' screen | otherwise -> s 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) 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