summaryrefslogtreecommitdiffstats
path: root/lib/Phi/Border.hs
blob: ca5e5153024c1922ba4f6c325efb1e1ce285e436 (plain)
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