{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}
module Graphics.UI.FLTK.Theme.Light.Common
(
configureTheme,
commonColor,
commonDarkGreyColor,
commonFillColor,
commonFont,
commonFontSize,
commonLargeFontSize,
commonSelectionColor,
lightBackground,
angleToCoordinate,
centerInRectangle,
centerInRectangleByRelativePosition,
degreesPerRadian,
fromFltkAngle,
insideRectangle,
intDiv,
isWidget,
percentOf,
percentOfSmallerEllipseRadius,
positionInside,
splitVertically,
splitVerticallyByPixels,
splitHorizontally,
splitHorizontallyByPixels,
withPositionX,
withPositionY,
withSizeHeight,
withSizeWidth,
withCustomBoxDraw,
BorderBoxSpec(..),
drawBorderBox,
FillSpec(..),
makeFillSpec,
borderRectangle,
fillRectangle,
handleHover,
OpenBorder(..),
roundedBoxPoints
)
where
import Control.Monad
import Graphics.UI.FLTK.LowLevel.Dispatch
import Graphics.UI.FLTK.LowLevel.FLTKHS hiding (colorAverage, isHorizontal, inactive, tabPositionsCustom, tabHeightCustom, tabDrawCustom, find, tabWhichCustom, tabRedrawTabs)
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.Theme.Light.Assets
import qualified Graphics.UI.FLTK.LowLevel.FL as FL
import Foreign.Ptr
data OpenBorder =
OpenBorderTop
| OpenBorderBottom
data BorderBoxSpec =
BorderBoxSpec
{
borderBoxBounds :: Rectangle,
borderBoxFocusedColor :: Color,
borderBoxHoveringColor :: Color,
borderBoxColor :: Color,
borderBoxFillColor :: Color
} deriving Show
data FillSpec =
FillSpec
{
fillBounds :: Rectangle
, fillTopColor :: Color
, fillTopSelectionColor :: Color
, fillTopFillPercentage :: Int
, fillBottomColor :: Color
, fillBottomSelectionColor :: Color
, fillBottomFillPercentage :: Int
, fillCornerRadius :: Int
, fillBorderColor :: Color
, fillBorderFocusColor :: Color
, fillBorderHovered :: Color
}
commonFont :: (?assets :: Assets) => Font
commonFont = dejaVuSans
commonFontSize :: FontSize
commonFontSize = FontSize 12
commonLargeFontSize :: FontSize
commonLargeFontSize = FontSize 22
commonColor :: IO Color
commonColor = rgbColorWithRgb (0xF9, 0xF9, 0xF9)
commonDarkGreyColor :: IO Color
commonDarkGreyColor = rgbColorWithRgb (80,81,84)
commonFillColor :: IO Color
commonFillColor = rgbColorWithRgb (0x66, 0x94, 0xE3)
lightBackground :: Color
lightBackground = whiteColor
fromFltkAngle :: PreciseAngle -> PreciseAngle
fromFltkAngle (PreciseAngle a) =
let unitCircleAngle = (270 - (truncate a)) `mod` 360
in
PreciseAngle
(if (unitCircleAngle < 0)
then 360.0 - (abs (fromIntegral unitCircleAngle))
else (fromIntegral unitCircleAngle))
degreesPerRadian :: Double
degreesPerRadian = pi/180
angleToCoordinate :: PreciseAngle -> PrecisePosition
angleToCoordinate (PreciseAngle a) =
case a of
_ | a == 360 -> PrecisePosition (PreciseX (cos 0)) (PreciseY (sin 0))
| otherwise ->
let radians = a * degreesPerRadian
in PrecisePosition (PreciseX (cos radians)) (PreciseY (sin radians))
percentOf :: Double -> Int -> Int
percentOf p a = truncate ((fromIntegral a) * p)
percentOfSmallerEllipseRadius :: Double -> PreciseSize -> Double
percentOfSmallerEllipseRadius percent (PreciseSize (PreciseWidth rW) (PreciseHeight rH)) = ((if (rW < rH) then rW else rH) * percent) / 100.0
commonSelectionColor :: IO Color
commonSelectionColor = rgbColorWithRgb (50, 100, 201)
isWidget :: (Parent a WidgetBase) => Ref a -> IO (Maybe (Ref b)) -> IO Bool
isWidget this thatM = thatM >>= maybe (return False) (refPtrEquals this)
insideRectangle :: Position -> Rectangle -> Bool
insideRectangle (Position (X x) (Y y)) rect =
let (rx,ry,rw,rh) = fromRectangle rect
in x >= rx && x <= rx+rw && y >= ry && y <= ry+rh
roundedBoxPoints :: Rectangle -> Maybe Int -> Maybe OpenBorder -> [Position]
roundedBoxPoints (Rectangle (Position (X x) (Y y)) (Size (Width w) (Height h))) maybeRadius maybeOpen =
let insideW = w-1
insideH = h-1
in
map toPosition
(case (maybeRadius,maybeOpen) of
(Just radius, Nothing) ->
[
(x+radius,y)
, (x+insideW-radius,y)
, (x+insideW,y+radius)
, (x+insideW,y+insideH-radius)
, (x+insideW-radius,y+insideH)
, (x+radius,y+insideH)
, (x,y+insideH-radius)
, (x,y+radius)
, (x+radius,y)
]
(Just radius, Just OpenBorderBottom) ->
[
(x,y+h)
, (x,y+radius)
, (x+radius,y)
, (x+insideW-radius,y)
, (x+insideW,y+radius)
, (x+insideW,y+h)
]
(Just radius, Just OpenBorderTop) ->
[
(x+insideW,y)
, (x+insideW,y+insideH-radius)
, (x+insideW-radius,y+insideH)
, (x+radius,y+insideH)
, (x,y+insideH-radius)
, (x,y)
]
(Nothing, Just OpenBorderBottom) ->
[
(x,y+insideH)
, (x,y)
, (x+insideW,y)
, (x+insideW,y+insideH)
]
(Nothing, Just OpenBorderTop) ->
[
(x,y)
, (x,y+insideH)
, (x+insideW,y+insideH)
, (x+insideW,y)
]
(Nothing, Nothing) ->
[
(x,y)
, (x+insideW,y)
, (x+insideW,y+insideH)
, (x,y+insideH)
, (x,y)
])
drawBorderBox :: (Parent a WidgetBase) => Ref a -> BorderBoxSpec -> Bool -> IO ()
drawBorderBox w spec shouldFill = do
oldColor <- flcColor
focused <- isWidget w FL.focus
hovering <- isWidget w FL.belowmouse
when shouldFill (flcRectfWithColor (borderBoxBounds spec) (borderBoxFillColor spec))
if focused
then flcSetColor (borderBoxFocusedColor spec)
else if hovering
then flcSetColor (borderBoxHoveringColor spec)
else flcSetColor (borderBoxColor spec)
flcBeginLine
mapM_ (flcVertex . toPrecisePosition) (roundedBoxPoints (borderBoxBounds spec) Nothing Nothing)
flcEndLine
flcSetColor oldColor
handleHover ::
(
orig ~ (a b),
Parent orig WidgetBase,
Match x ~ FindOp orig orig (Redraw ()),
Op (Redraw ()) x orig (IO ())
)
=> Ref orig -> Event -> IO (Either UnknownEvent ())
handleHover b e = do
case e of
Enter -> do
() <- redraw b
return (Right())
Leave -> do
() <- redraw b
return (Right ())
_ -> return (Left UnknownEvent)
withCustomBoxDraw :: Boxtype -> BoxDrawF -> IO () -> IO ()
withCustomBoxDraw boxtype customBoxDrawF action = do
oldFptr <- FL.getBoxtype boxtype
dx <- FL.boxDx boxtype
dy <- FL.boxDy boxtype
dw <- FL.boxDw boxtype
dh <- FL.boxDh boxtype
FL.setBoxtype boxtype (FL.FromSpec customBoxDrawF 0 0 0 0)
action
fptr <- FL.getBoxtype boxtype
when (fptr /= nullFunPtr) (freeHaskellFunPtr fptr)
FL.setBoxtype boxtype (FL.FromFunPtr oldFptr (fromIntegral dx) (fromIntegral dy) (fromIntegral dw) (fromIntegral dh))
makeFillSpec :: Rectangle -> Color -> Color -> IO FillSpec
makeFillSpec rect color selectionColor = do
(colorR, colorG, colorB) <- FL.getColorRgb color
pressedColor <- rgbColorWithRgb (colorR - 21, colorG - 21, colorB - 21)
let slightlyDarker = colorAverage color blackColor 0.93
let slightlyLighter = colorAverage whiteColor pressedColor 0.93
hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB)
let darkerSelectionColor = darker selectionColor
return
FillSpec
{
fillBounds = rect,
fillTopColor = color,
fillTopSelectionColor = pressedColor,
fillTopFillPercentage = 30,
fillBottomColor = slightlyDarker,
fillBottomSelectionColor = slightlyLighter,
fillBottomFillPercentage = 70,
fillCornerRadius = 2,
fillBorderColor = slightlyDarker,
fillBorderFocusColor = darkerSelectionColor,
fillBorderHovered = hoverColor
}
borderRectangle :: FillSpec -> Bool -> Bool -> IO ()
borderRectangle spec focused hovering = do
oldColor <- flcColor
if focused
then flcSetColor (fillBorderFocusColor spec)
else if hovering
then flcSetColor (fillBorderHovered spec)
else flcSetColor (fillBorderColor spec)
flcBeginLine
mapM_ (flcVertex . toPrecisePosition) (roundedBoxPoints (fillBounds spec) (Just (fillCornerRadius spec)) Nothing)
flcEndLine
flcLineStyle (LineDrawStyle (Just LineStyleSolid) Nothing Nothing) Nothing Nothing
flcSetColor oldColor
fillRectangle :: FillSpec -> Bool -> IO ()
fillRectangle spec pressed = do
if pressed
then drawButton (fillTopSelectionColor spec) (fillBottomSelectionColor spec)
else drawButton (fillTopColor spec) (fillBottomColor spec)
where
drawButton topColor bottomColor = do
let diameter = (fillCornerRadius spec) * 2
quarterCircle x y a1 a2 = do
fillColor <- flcColor
flcPie (toRectangle (x,y,diameter,diameter)) a1 a2
flcSetColor fillColor
oldColor <- flcColor
let (x,y,w,h) = fromRectangle (fillBounds spec)
insideW = w
insideH = h
topFillFraction :: Double
topFillFraction = (fromIntegral (fillTopFillPercentage spec)) / 100.0
topHeight = truncate (fromIntegral insideH * topFillFraction)
flcSetColor topColor
flcRectf (toRectangle (x + (fillCornerRadius spec), y, insideW - diameter, (fillCornerRadius spec)))
flcRectf (toRectangle (x, y + (fillCornerRadius spec), insideW , topHeight - (fillCornerRadius spec)))
let bottomFillFraction :: Double
bottomFillFraction = (fromIntegral (fillBottomFillPercentage spec)) / 100.0
bottomHeight = truncate (fromIntegral insideH * bottomFillFraction)
flcSetColor bottomColor
when (diameter > 0)
(do
quarterCircle x y (PreciseAngle 90.0) (PreciseAngle 180.0)
quarterCircle (x + (insideW - diameter)) y (PreciseAngle 0) (PreciseAngle 90.0)
quarterCircle x (y + (insideH - diameter)) (PreciseAngle 180.0) (PreciseAngle 270.0)
quarterCircle (x + (insideW - diameter)) (y + (insideH - diameter)) (PreciseAngle 270.0) (PreciseAngle 360.0)
flcRectf (toRectangle (x + (fillCornerRadius spec), y + h - (fillCornerRadius spec), insideW - (diameter), (fillCornerRadius spec))))
flcRectf (toRectangle (x, y + bottomHeight, insideW, h - bottomHeight - (fillCornerRadius spec)))
let middleFraction = fromIntegral (fillBottomFillPercentage spec - fillTopFillPercentage spec) / 100.0
totalSteps :: Double
totalSteps = fromIntegral h * middleFraction
stepSize :: Double
stepSize = 1.0 / totalSteps
mapM_
(
\step -> do
let weight = 1.0 - (stepSize * fromIntegral step)
blendColor =
colorAverage
topColor
bottomColor
weight
flcSetColor blendColor
flcXyline (toPosition (x,y + topHeight + step)) (X (x + insideW - 1))
)
[0 .. truncate totalSteps - 1]
flcSetColor oldColor
centerInRectangle :: Rectangle -> Size -> Position
centerInRectangle r (Size (Width sW) (Height sH)) =
let (rX,rY,rW,rH) = fromRectangle r
posX = rX + ((rW-sW) `intDiv` 2)
posY = rY + ((rH-sH) `intDiv` 2)
in toPosition (posX,posY)
centerInRectangleByRelativePosition :: Rectangle -> X -> Y -> Rectangle
centerInRectangleByRelativePosition r (X xOff) (Y yOff) =
let (rX,rY,rW,rH) = fromRectangle r
r2W = rW - (2*xOff)
r2H = rH - (2*yOff)
in toRectangle (rX+xOff,rY+yOff,r2W,r2H)
positionInside :: Rectangle -> Size -> X -> Y -> Rectangle
positionInside r (Size (Width sW) (Height sH)) (X xOff) (Y yOff) =
let (rX,rY,_,_) = fromRectangle r
in toRectangle (rX+xOff,rY+yOff,sW,sH)
withSizeHeight :: Size -> (Height -> Height) -> Size
withSizeHeight (Size w h) f = Size w (f h)
withSizeWidth :: Size -> (Width -> Width) -> Size
withSizeWidth (Size w h) f = Size (f w) h
withPositionX :: Position -> (X -> X) -> Position
withPositionX (Position x y) f = Position (f x) y
withPositionY :: Position -> (Y -> Y) -> Position
withPositionY (Position x y) f = Position x (f y)
splitVertically :: Rectangle -> Double -> (Rectangle, Rectangle)
splitVertically r percent =
let (rx,ry,rw,rh) = fromRectangle r
r1w = truncate ((fromIntegral rw) * percent)
r2w = rw-r1w
r2x = rx+r1w
in (toRectangle (rx,ry,r1w,rh), toRectangle (r2x,ry,r2w,rh))
splitVerticallyByPixels :: Rectangle -> Int -> (Rectangle, Rectangle)
splitVerticallyByPixels r ps =
let (rx,ry,rw,rh) = fromRectangle r
r1w = if (ps >= rw) then rw else ps
r2w = rw-r1w
r2x = rx+r1w
in (toRectangle (rx,ry,r1w,rh), toRectangle (r2x,ry,r2w,rh))
splitHorizontally :: Rectangle -> Double -> (Rectangle, Rectangle)
splitHorizontally r percent =
let (rx,ry,rw,rh) = fromRectangle r
r1h = truncate ((fromIntegral rh) * percent)
r2h = rh-r1h
r2y = ry+r1h
in (toRectangle (rx,ry,rw,r1h), toRectangle (rx,r2y,rw,r2h))
splitHorizontallyByPixels :: Rectangle -> Int -> (Rectangle,Rectangle)
splitHorizontallyByPixels r ps =
let (rx,ry,rw,rh) = fromRectangle r
r1h = if (ps >= rh) then rh else ps
r2h = rh-r1h
r2y = ry+r1h
in (toRectangle (rx,ry,rw,r1h), toRectangle (rx,r2y,rw,r2h))
intDiv :: Int -> Int -> Int
intDiv num denom = truncate (((fromIntegral num) / (fromIntegral denom)) :: Double)
configureTheme :: IO Assets
configureTheme = do
assets <- loadAssets
let ?assets = assets
FL.setColor background2Color lightBackground
tooltipSetFont commonFont
tooltipSetSize commonFontSize
return assets