{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}
module Graphics.UI.FLTK.Theme.Light.Button
(
FillSpec(..),
buttonFillSpec,
buttonIsHidden,
buttonNew,
buttonSetup,
cancelButtonNew,
checkButtonNew,
drawCheck,
drawIndicatorButton,
drawLight,
drawMenuButton,
drawRegularButton,
drawRound,
fillRectangle,
lightButtonNew,
menuButtonNew,
okButtonNew,
returnButtonNew,
roundButtonNew,
toggleButtonNew
)
where
import Control.Exception
import Control.Monad
import Graphics.UI.FLTK.LowLevel.Dispatch
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.Theme.Light.Common
import Text.Printf
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Graphics.UI.FLTK.LowLevel.FL as FL
import qualified Graphics.UI.FLTK.LowLevel.FLTKHS as LowLevel
import qualified Graphics.UI.FLTK.LowLevel.Dispatch
import Graphics.UI.FLTK.Theme.Light.Assets
buttonIsHidden :: Ref LowLevel.Button -> IO Bool
buttonIsHidden b = do
t <- LowLevel.getType_ b
case t of
HiddenButtonType -> return True
_ -> return False
drawRegularButton :: FillSpec -> Ref LowLevel.Button -> IO ()
drawRegularButton spec b = do
buttonType <- LowLevel.getType_ b
case buttonType of
HiddenButtonType -> return ()
_ -> do
pressed <- LowLevel.getValue b
fillRectangle spec pressed
focused <- isWidget b FL.focus
hovering <- isWidget b FL.belowmouse
borderRectangle spec focused hovering
LowLevel.drawLabel b Nothing
drawIndicatorButton ::
(
Parent orig LowLevel.Widget,
Match b ~ FindOp orig orig (LowLevel.ActiveR ()),
Op (LowLevel.ActiveR ()) b orig (IO Bool),
Match c ~ FindOp orig orig (LowLevel.GetAlign ()),
Op (LowLevel.GetAlign ()) c orig (IO Alignments),
Match d ~ FindOp orig orig (LowLevel.GetImage ()),
Op (LowLevel.GetImage ()) d orig (IO (Maybe (Ref LowLevel.Image))),
Match e ~ FindOp orig orig (LowLevel.GetSelectionColor ()),
Op (LowLevel.GetSelectionColor ()) e orig (IO Color),
Match g ~ FindOp orig orig (LowLevel.GetRectangle ()),
Op (LowLevel.GetRectangle ()) g orig (IO Rectangle),
Match h ~ FindOp orig orig (LowLevel.GetColor ()),
Op (LowLevel.GetColor ()) h orig (IO Color),
Match i ~ FindOp orig orig (LowLevel.GetLabelsize ()),
Op (LowLevel.GetLabelsize ()) i orig (IO FontSize),
Match j ~ FindOp orig orig (LowLevel.DrawLabel ()),
Op (LowLevel.DrawLabel ()) j orig (Maybe (Rectangle,Alignments) -> IO ()),
Match k ~ FindOp orig orig (LowLevel.GetBox ()),
Op (LowLevel.GetBox ()) k orig (IO (Boxtype)),
Match l ~ FindOp orig orig (LowLevel.GetParent ()),
Op (LowLevel.GetParent ()) l orig (IO (Maybe (Ref LowLevel.Group))),
Match m ~ FindOp orig orig (LowLevel.GetColor ()),
Op (LowLevel.GetColor ()) m orig (IO (Color)),
Match n ~ FindOp orig orig (LowLevel.SetColor ()),
Op (LowLevel.SetColor ()) n orig (Color -> IO ())
) => (FillSpec -> Bool -> Color -> FontSize -> IO Rectangle) -> Bool -> Bool -> Bool -> FontSize -> Ref orig -> IO ()
drawIndicatorButton indicator pressed transparent hidden fs b =
if hidden then return ()
else do
spec <- buttonFillSpec b
boxType <- LowLevel.getBox b
active <- LowLevel.activeR b
if (not transparent)
then case boxType of
NoBox -> return ()
_ -> do
fillRectangle spec pressed
focused <- isWidget b FL.focus
hovering <- isWidget b FL.belowmouse
borderRectangle spec focused hovering
else do
maybeParent <- LowLevel.getParent b
case maybeParent of
Just (p :: Ref LowLevel.Group) -> do
c <- LowLevel.getColor p
() <- LowLevel.setColor b c
focused <- isWidget b FL.focus
hovering <- isWidget b FL.belowmouse
borderRectangle (spec { fillBorderColor = lightBackground }) focused hovering
Nothing -> return ()
let (x,y,w,h) = fromRectangle (fillBounds spec)
color <- LowLevel.getSelectionColor b
indicatorBounds <- indicator spec (pressed && active) color fs
let (indicatorX, _, indicatorW, _) = fromRectangle indicatorBounds
(alignments :: Alignments) <- LowLevel.getAlign b
(imageM :: Maybe (Ref LowLevel.Image)) <- LowLevel.getImage b
let labelBounds = case imageM of
Nothing -> toRectangle (x + fillCornerRadius spec, y, w - (fillCornerRadius spec * 2), h)
Just _ ->
let widthLeftCut = indicatorX + indicatorW - x
widthRightCut = fillCornerRadius spec
in toRectangle (indicatorX + indicatorW, y, w - (widthLeftCut + widthRightCut),h)
LowLevel.drawLabel b (Just (labelBounds, alignments))
drawDownArrow :: Rectangle -> Color -> FontSize -> IO Rectangle
drawDownArrow bounds arrowColor (FontSize size)=
let arrowSize :: Int
arrowSize = (fromIntegral size) `intDiv` 2
(x,y,w,h) = fromRectangle bounds
arrowX = x + w - arrowSize - arrowSize
arrowY :: Int
arrowY = y + (h `intDiv` 2) - (arrowSize `intDiv` 2)
arrowBoundingBox = toRectangle (arrowX, arrowY, arrowSize, arrowSize)
in do
oldColor <- LowLevel.flcColor
LowLevel.flcSetColor arrowColor
LowLevel.flcBeginPolygon
LowLevel.flcVertex (PrecisePosition (PreciseX (fromIntegral arrowX)) (PreciseY (fromIntegral arrowY)))
LowLevel.flcVertex (PrecisePosition (PreciseX (fromIntegral (arrowX+arrowSize))) (PreciseY (fromIntegral arrowY)))
LowLevel.flcVertex (PrecisePosition (PreciseX ((fromIntegral arrowX) + (fromIntegral arrowSize)/2)) (PreciseY (fromIntegral (arrowY + arrowSize))))
LowLevel.flcVertex (PrecisePosition (PreciseX (fromIntegral arrowX)) (PreciseY (fromIntegral arrowY)))
LowLevel.flcEndPolygon
return arrowBoundingBox
drawMenuButton :: Ref LowLevel.MenuButton -> IO ()
drawMenuButton m = do
t <- LowLevel.getType_ m
b <- LowLevel.getBox m
let noBox = case b of { NoBox -> True; _ -> False }
if (t /= 0 || noBox) then return ()
else do
fillSpec <- buttonFillSpec m
itemIndex <- LowLevel.getValue m
fontSize <- LowLevel.getLabelsize m
drawIndicatorButton (\spec _ color fs -> drawDownArrow (fillBounds spec) color fs) (maybe False (const True) itemIndex) False False fontSize m
drawLight :: FillSpec -> Bool -> Color -> FontSize -> IO Rectangle
drawLight spec lightOn lightColor (FontSize lightDiameter) =
let (x,y,w,h) = fromRectangle (fillBounds spec)
lightX = x + 3
lightY = y + (h `intDiv` 2)
lightRadius = (fromIntegral lightDiameter / 2.0)
lightBoundingBox = toRectangle (lightX, (lightY - truncate lightRadius), fromIntegral lightDiameter, fromIntegral lightDiameter)
in do
oldColor <- LowLevel.flcColor
when lightOn
(do
LowLevel.flcSetColor lightColor
LowLevel.flcPie lightBoundingBox (PreciseAngle 0.0) (PreciseAngle 360.0)
)
LowLevel.flcSetColor (fillBorderColor spec)
LowLevel.flcCircle (PrecisePosition (PreciseX (fromIntegral (lightX + truncate lightRadius))) (PreciseY (fromIntegral lightY))) lightRadius
LowLevel.flcSetColor oldColor
return lightBoundingBox
drawRound :: FillSpec -> Bool -> Color -> FontSize -> IO Rectangle
drawRound spec radioOn radioColor (FontSize fs) =
let (x,y,w,h) = fromRectangle (fillBounds spec)
radioBoxX = x + 3
radioBoxY = fromIntegral y + (fromIntegral h / 2.0)
radioBoxWidth :: Int
radioBoxWidth = fromIntegral fs
radioBoxHalfway :: Double
radioBoxHalfway = (fromIntegral radioBoxWidth) / 2.0
radioBoundingBox =
toRectangle (radioBoxX, truncate (radioBoxY - radioBoxHalfway), radioBoxWidth, radioBoxWidth)
circleSvg =
"<svg width=\"%d\" height=\"%d\" viewBox=\" %f %f %d %d\">\n" ++
"<circle cx=\"0\" cy=\"0\" r=\"%f\" fill=\"%s\" stroke=\"%s\"/>" ++
"</svg>\n"
radioRadius = (fromIntegral radioBoxWidth) / 4.5
radioDiameter = radioRadius * 2
radioX = fromIntegral radioBoxX + radioBoxHalfway - radioRadius
radioY = radioBoxY - radioRadius
in do
(borderColorR, borderColorG, borderColorB) <- FL.getColorRgb (fillBorderColor spec)
(radioColorR, radioColorG, radioColorB) <- FL.getColorRgb (if radioOn then radioColor else (fillTopColor spec))
let svg =
"<svg>\n" ++
(printf circleSvg
radioBoxWidth radioBoxWidth (-radioBoxHalfway) (-radioBoxHalfway) radioBoxWidth radioBoxWidth
(radioBoxHalfway-1.0) ("none" :: String) ("rgb(" ++ show borderColorR ++ "," ++ show borderColorG ++ "," ++ show borderColorB ++ ")")) ++
(printf circleSvg
radioBoxWidth radioBoxWidth (-radioBoxHalfway) (-radioBoxHalfway) radioBoxWidth radioBoxWidth
(radioRadius-1.0) ("rgb(" ++ show radioColorR ++ "," ++ show radioColorG ++ "," ++ show radioColorB ++ ")") ("rgb(" ++ show radioColorR ++ "," ++ show radioColorG ++ "," ++ show radioColorB ++ ")")) ++
"</svg>\n"
iE <- LowLevel.svgImageNew ((TE.encodeUtf8 . T.pack) svg)
case iE of
Left _ -> throwIO (userError ("The generated SVG is invalid: \n" ++ svg))
Right i -> do
LowLevel.draw i (toPosition (radioBoxX,truncate (radioBoxY - radioBoxHalfway)))
LowLevel.destroy i
return radioBoundingBox
drawCheck :: FillSpec -> Bool -> Color -> FontSize -> IO Rectangle
drawCheck spec checked checkColor (FontSize fontSize) =
let (x,y,w,h) = fromRectangle (fillBounds spec)
checkBoxWidth :: Int = fromIntegral fontSize
checkBoxHeight = checkBoxWidth
checkBoxX = x + 3
checkBoxMiddle = fromIntegral checkBoxHeight / 2.0
checkBoxFourth = fromIntegral checkBoxHeight / 4.0
yOffset = (h - fromIntegral checkBoxHeight) `intDiv` 2
pad = 1
checkThickness = 2
checkBoxY = y + yOffset
checkBoxRectangle = toRectangle (checkBoxX, checkBoxY, checkBoxWidth, checkBoxHeight)
in do
when checked
(let
downstrokeStart = Position (X (checkBoxX + pad)) (Y (checkBoxY + truncate checkBoxMiddle))
upstrokeStart = Position (X (checkBoxX + pad + truncate checkBoxFourth)) (Y (checkBoxY - pad + checkBoxHeight))
in do
LowLevel.flcSetColor checkColor
LowLevel.flcPolygonWith4Sides
downstrokeStart
(Position (X (checkBoxX + pad + checkThickness)) (Y (checkBoxY + truncate checkBoxMiddle)))
(Position (X (checkBoxX + pad + truncate checkBoxFourth + checkThickness)) (Y (checkBoxY - pad + checkBoxHeight)))
(Position (X (checkBoxX + pad + truncate checkBoxFourth)) (Y (checkBoxY - pad + checkBoxHeight)))
LowLevel.flcPolygonWith4Sides
upstrokeStart
(Position (X (checkBoxX + checkBoxWidth - pad - checkThickness)) (Y (checkBoxY + pad)))
(Position (X (checkBoxX + checkBoxWidth - pad)) (Y (checkBoxY + pad)))
(Position (X (checkBoxX + pad + truncate checkBoxFourth + checkThickness)) (Y (checkBoxY - pad + checkBoxHeight)))
)
oldColor <- LowLevel.flcColor
LowLevel.flcSetColor (fillBorderColor spec)
LowLevel.flcRect checkBoxRectangle
LowLevel.flcSetColor oldColor
return checkBoxRectangle
buttonFillSpec ::
(
Match w ~ FindOp orig orig (LowLevel.GetRectangle ()),
Op (LowLevel.GetRectangle ()) w orig (IO Rectangle),
Match x ~ FindOp orig orig (LowLevel.GetColor ()),
Op (LowLevel.GetColor ()) x orig (IO Color),
Match y ~ FindOp orig orig (LowLevel.GetLabelsize ()),
Op (LowLevel.GetLabelsize ()) y orig (IO FontSize),
Match z ~ FindOp orig orig (LowLevel.GetSelectionColor ()),
Op (LowLevel.GetSelectionColor ()) z orig (IO Color)
) => Ref orig -> IO FillSpec
buttonFillSpec b = do
rect <- LowLevel.getRectangle b
color <- LowLevel.getColor b
selectionColor <- LowLevel.getSelectionColor b
makeFillSpec rect color selectionColor
buttonSetup ::
(
?assets :: Assets,
Match w ~ FindOp orig orig (LowLevel.SetColor ()),
Op (LowLevel.SetColor ()) w orig (Color -> IO ()),
Match x ~ FindOp orig orig (LowLevel.SetLabelfont ()),
Op (LowLevel.SetLabelfont ()) x orig (Font -> IO ()),
Match y ~ FindOp orig orig (LowLevel.SetLabelsize ()),
Op (LowLevel.SetLabelsize ()) y orig (FontSize -> IO ()),
Match z ~ FindOp orig orig (LowLevel.SetAlign ()),
Op (LowLevel.SetAlign ()) z orig (Alignments -> IO ())
) => Ref orig -> IO ()
buttonSetup b = do
color <- commonColor
() <- LowLevel.setColor b color
() <- LowLevel.setLabelfont b commonFont
() <- LowLevel.setLabelsize b commonFontSize
LowLevel.setAlign b (Alignments [AlignTypeInside, AlignTypeCenter , AlignTypeImageNextToText])
buttonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Button)
buttonNew rectangle label = do
b <- LowLevel.buttonCustom
rectangle
label
(Just (\b -> do
spec <- buttonFillSpec b
drawRegularButton spec b))
(Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = Just handleHover }))
buttonSetup b
return b
toggleButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ToggleButton)
toggleButtonNew rectangle label = do
b <- LowLevel.buttonCustom
rectangle
label
(Just (\b -> do
spec <- buttonFillSpec b
drawRegularButton spec b))
(Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover ) }))
LowLevel.setType b ToggleButtonType
buttonSetup b
return (LowLevel.castTo b)
lightButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.LightButton)
lightButtonNew rectangle label = do
b <- LowLevel.lightButtonCustom
rectangle
label
(Just (\b -> do
pressed <- LowLevel.getValue b
hidden <- buttonIsHidden (safeCast b)
fontSize <- LowLevel.getLabelsize b
drawIndicatorButton drawLight pressed False hidden fontSize b))
(Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))
buttonSetup b
LowLevel.setSelectionColor b yellowColor
LowLevel.setAlign b (Alignments [AlignTypeInside, AlignTypeCenter, AlignTypeImageNextToText])
return b
checkButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.CheckButton)
checkButtonNew rectangle label = do
b <- LowLevel.checkButtonCustom
rectangle
label
(Just (\b -> do
hidden <- buttonIsHidden (safeCast b)
when (not hidden)
(do
(x,y,w,h) <- fmap fromRectangle (LowLevel.getRectangle b)
bx <- FL.boxDx BorderBox
c <- LowLevel.getColor b
(FontSize labelWCInt) <- LowLevel.getLabelsize b
let labelW = fromIntegral labelWCInt
let dx = bx + 2
dy = (h-labelW) `intDiv` 2
LowLevel.flcDrawBox BorderBox (toRectangle (x+dx,y+dy,labelW,labelW)) c
v <- LowLevel.getValue b
when v
(do
let tx = x+dx+1
tw = labelW-1
d1 = tw `intDiv` 3
d2 = tw-d1
ty = y+dy+((labelW+d2) `intDiv` 2)-d1-2
oldC <- LowLevel.flcColor
LowLevel.flcSetColor blackColor
mapM_
(\i -> do
let ty' = ty+i
LowLevel.flcLine (toPosition (tx,ty')) (toPosition (tx+d1,ty'+d1))
LowLevel.flcLine (toPosition (tx+d1,ty'+d1)) (toPosition (tx+tw-1,ty'+d1-d2+1)))
[0 .. 2]
LowLevel.flcSetColor oldC
)
let lx = dx+labelW+2
alignments <- LowLevel.getAlign b
LowLevel.drawLabel b (Just (toRectangle (x+lx,y,w-lx-bx,h), alignments)))))
Nothing
color <- commonColor
() <- LowLevel.setColor b color
() <- LowLevel.setLabelfont b commonFont
() <- LowLevel.setLabelsize b commonFontSize
LowLevel.setSelectionColor b color
return b
roundButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.RoundButton)
roundButtonNew rectangle label = do
b <- LowLevel.roundButtonCustom
rectangle
label
(Just (\b -> do
hidden <- buttonIsHidden (safeCast b)
when (not hidden)
(do
(x,y,w,h) <- fmap fromRectangle (LowLevel.getRectangle b)
bx <- FL.boxDx BorderBox
c <- LowLevel.getColor b
(FontSize labelWCInt) <- LowLevel.getLabelsize b
v <- LowLevel.getValue b
let labelW :: Int
labelW = fromIntegral labelWCInt
dx = bx + 2
dy = (h-labelW) `intDiv` 2
circleSvg =
"<svg width=\"%d\" height=\"%d\" viewBox=\" %f %f %d %d\">\n" ++
"<circle cx=\"0\" cy=\"0\" r=\"%f\" fill=\"%s\" stroke=\"%d\"/>" ++
"</svg>\n"
halfway :: Double
halfway = (fromIntegral labelW)/2
radius :: Double
radius = (fromIntegral labelW)/4.5
(Color black') = blackColor
black :: Int
black = fromIntegral black'
svg =
"<svg>\n" ++
(printf circleSvg
labelW labelW (-halfway) (-halfway) labelW labelW
(halfway-1.0) ("none" :: String) black) ++
(if v
then
printf circleSvg
labelW labelW (-halfway) (-halfway) labelW labelW
(radius-1.0) ("black" :: String) black
else "")
++
"</svg>\n"
iE <- LowLevel.svgImageNew ((TE.encodeUtf8 . T.pack) svg)
case iE of
Left _ -> throwIO (userError ("The generated SVG is invalid: \n" ++ svg))
Right i -> do
LowLevel.draw i (toPosition (x+dx,y+dy))
LowLevel.destroy i
let lx = dx+labelW+2
alignments <- LowLevel.getAlign b
LowLevel.drawLabel b (Just (toRectangle (x+lx,y,w-lx-bx,h), alignments)))))
Nothing
color <- commonColor
() <- LowLevel.setColor b color
() <- LowLevel.setLabelfont b commonFont
() <- LowLevel.setLabelsize b commonFontSize
LowLevel.setSelectionColor b color
return b
menuButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.MenuButton)
menuButtonNew rect l = do
m <- LowLevel.menuButtonCustom rect l (Just drawMenuButton) Nothing
buttonSetup m
LowLevel.setBox m BorderBox
LowLevel.setTextfont m commonFont
LowLevel.setTextsize m commonFontSize
color <- commonSelectionColor
LowLevel.setSelectionColor m color
return m
returnButtonNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ReturnButton)
returnButtonNew rect l = do
b <- LowLevel.returnButtonCustom rect l
(Just ((\b -> do
spec <- buttonFillSpec b
drawRegularButton spec b) . safeCast))
(Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = Just handleHover }))
buttonSetup b
let (_,_,w',h') = fromRectangle rect
LowLevel.setAlign b (Alignments [AlignTypeTextNextToImage])
iM <- LowLevel.copy returnButtonImage Nothing
case iM of
Nothing -> return ()
Just i -> do
LowLevel.scale i (Size (Width (w' `intDiv` 3)) (Height (h' `intDiv` 2))) Nothing Nothing
LowLevel.setImage b iM
return b
okButtonNew :: (?assets :: Assets) => Rectangle -> IO (Ref LowLevel.Button)
okButtonNew rect = do
b <- buttonNew rect (Just "OK")
iM <- LowLevel.copy okButtonImage Nothing
let (_,_,w',h') = fromRectangle rect
case iM of
Nothing -> return ()
Just i -> do
LowLevel.scale i (Size (Width (w' `intDiv` 3)) (Height (h' `intDiv` 2))) Nothing Nothing
LowLevel.setImage b iM
return b
cancelButtonNew :: (?assets :: Assets) => Rectangle -> IO (Ref LowLevel.Button)
cancelButtonNew rect = do
b <- buttonNew rect (Just "Cancel")
iM <- LowLevel.copy cancelButtonImage Nothing
let (_,_,w',h') = fromRectangle rect
case iM of
Nothing -> return ()
Just i -> do
LowLevel.scale i (Size (Width (w' `intDiv` 3)) (Height (h' `intDiv` 2))) Nothing Nothing
LowLevel.setImage b iM
return b