phi/lib/Phi/Border.hs

{-# 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