{-# LANGUAGE ImplicitParams, OverloadedStrings, AllowAmbiguousTypes, GADTs, CPP, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}
module Graphics.UI.FLTK.Theme.Light.Slider
(
sliderNew,
fillSliderNew,
valueSliderNew,
gaugeSliderNew,
horFillSliderNew,
horNiceSliderNew,
horSliderNew,
horValueSliderNew,
GaugeSliderSpec(..),
defaultGaugeHeight,
drawSlider,
drawValueSlider,
gaugeBoxBounds,
sliderIsHorizontal,
mkGaugeSliderSpec,
sliderKnobColor,
sliderSetup
)
where
import Control.Exception
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.Hierarchy as Hierarchy
import qualified Graphics.UI.FLTK.LowLevel.Dispatch
import Graphics.UI.FLTK.Theme.Light.Assets
sliderKnobColor :: IO Color
sliderKnobColor = rgbColorWithRgb (241,241,241)
sliderIsHorizontal :: SliderType -> Bool
sliderIsHorizontal VertSliderType = False
sliderIsHorizontal HorSliderType = True
sliderIsHorizontal VertFillSliderType = False
sliderIsHorizontal HorFillSliderType = True
sliderIsHorizontal VertNiceSliderType = False
sliderIsHorizontal HorNiceSliderType = True
sliderSetup ::
(?assets :: Assets) => Ref LowLevel.Slider -> IO ()
sliderSetup s = do
() <- LowLevel.setColor s lightBackground
() <- LowLevel.setBox s BorderBox
() <- LowLevel.setSlider s UpBox
() <- LowLevel.setSliderSize s 0.15
() <- LowLevel.setLabelfont s commonFont
() <- LowLevel.setLabelsize s commonFontSize
color <- commonSelectionColor
LowLevel.setSelectionColor s color
data GaugeSliderSpec =
GaugeSliderSpec
{
gaugeHeight :: Int
, gaugeWidth :: Double
, gaugeOverhang :: Double
}
defaultGaugeHeight :: Int
defaultGaugeHeight = 10
mkGaugeSliderSpec =
GaugeSliderSpec
{
gaugeHeight = defaultGaugeHeight
, gaugeWidth = 0.20
, gaugeOverhang = (fromIntegral defaultGaugeHeight)/2
}
drawValueSlider :: Ref LowLevel.ValueSlider -> IO ()
drawValueSlider vs = do
color <- LowLevel.getColor vs
selectionColor <- fmap darker (LowLevel.getSelectionColor vs)
let slightlyDarker = Graphics.UI.FLTK.LowLevel.Fl_Enumerations.colorAverage color blackColor 0.85
hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB)
(x,y,w,h) <- fmap fromRectangle (LowLevel.getRectangle vs)
sliderType <- LowLevel.getType_ vs
let spec =
BorderBoxSpec
{
borderBoxHoveringColor = hoverColor,
borderBoxColor = slightlyDarker,
borderBoxFocusedColor = selectionColor,
borderBoxFillColor = color,
borderBoxBounds =
toRectangle
(if (sliderIsHorizontal sliderType)
then (x,y,valueBoxWidth-1,h-1)
else (x,y,w-1, valueBoxHeight-1)
)
}
drawBorderBox vs spec True
valueFont <- LowLevel.getTextfont vs
valueFontsize <- LowLevel.getTextsize vs
valueFontcolor <- LowLevel.getTextcolor vs
LowLevel.flcSetFont valueFont valueFontsize
isActive <- LowLevel.activeR vs
LowLevel.flcSetColor (if isActive then valueFontcolor else (inactive valueFontcolor))
currentValue <- LowLevel.format vs
case currentValue of
Left _ -> return ()
Right text -> LowLevel.flcDrawInBox text (borderBoxBounds spec) (Alignments [AlignTypeClip]) Nothing Nothing
drawSlider
(castTo vs)
Nothing
(toRectangle
(if (sliderIsHorizontal sliderType)
then (x+valueBoxWidth,y,w-valueBoxWidth,h)
else (x,y+valueBoxHeight,w,h-valueBoxHeight)
)
)
where
valueBoxWidth = 35
valueBoxHeight = 25
gaugeBoxBounds :: Bool -> GaugeSliderSpec -> Rectangle -> Rectangle
gaugeBoxBounds horizontal spec rect =
let (x,y,w,h) = fromRectangle rect
horizontalBounds =
(
x+(truncate (gaugeOverhang spec))
, y+(truncate ((gaugeWidth spec)*(fromIntegral h)))
, w-(2*(truncate (gaugeOverhang spec)))
, h-(2*(truncate ((gaugeWidth spec)*(fromIntegral h))))
)
verticalBounds =
(
x+(truncate ((gaugeWidth spec)*(fromIntegral w)))
, y+(truncate (gaugeOverhang spec))
, w-(2*(truncate ((gaugeWidth spec)*(fromIntegral w))))
, h-(2*(truncate (gaugeOverhang spec)))
)
in toRectangle (if horizontal then horizontalBounds else verticalBounds)
drawSlider :: Ref LowLevel.Slider -> Maybe GaugeSliderSpec -> Rectangle -> IO ()
drawSlider s gaugeSpec rect = do
color <- LowLevel.getColor s
selectionColor <- fmap darker (LowLevel.getSelectionColor s)
let (x,y,w,h) = fromRectangle rect
slightlyDarker = colorAverage color blackColor 0.85
hoverColor <- rgbColorWithRgb (0xBB, 0xBB, 0xBB)
t <- LowLevel.getType_ s
let spec =
BorderBoxSpec
{
borderBoxHoveringColor = hoverColor,
borderBoxColor = slightlyDarker,
borderBoxFocusedColor = selectionColor,
borderBoxFillColor = color,
borderBoxBounds =
case gaugeSpec of
Nothing -> toRectangle (x,y,w-1,h-1)
Just spec -> gaugeBoxBounds (sliderIsHorizontal t) spec rect
}
(xDiff,yDiff,wDiff,hDiff) = FL.boxDifferences rect (borderBoxBounds spec)
drawBorderBox s spec (maybe True (\_ -> False) gaugeSpec)
LowLevel.drawLabel s Nothing
min' <- LowLevel.getMinimum s
max' <- LowLevel.getMaximum s
value' <- fmap (sliderValue min' max') (LowLevel.getValue s)
oldColor <- LowLevel.flcColor
case gaugeSpec of
Nothing -> drawPill rect value' (sliderIsHorizontal t)
Just gaugeSpec ->
let (xDiff,yDiff,wDiff,hDiff) = FL.boxDifferences rect (borderBoxBounds spec)
(xPad,yPad) = (xDiff `intDiv` 2, yDiff `intDiv` 2)
in do
LowLevel.flcRectfWithColor (toRectangle (x,y,w,yDiff)) color
LowLevel.flcRectfWithColor (toRectangle (x,y+yDiff,xDiff,h-(yDiff*2))) color
LowLevel.flcRectfWithColor (toRectangle (x+w-xDiff,y+yDiff,xDiff,h-(yDiff*2))) color
LowLevel.flcRectfWithColor (toRectangle (x,y+h-yDiff,w,yDiff)) color
triangleColor <- FL.getColorRgb (colorAverage slightlyDarker blackColor 0.85)
drawGauge (borderBoxBounds spec) triangleColor rect value' (sliderIsHorizontal t) gaugeSpec
where
gaugeSvg (borderR,borderG,borderB) bounds innerBounds v horizontal spec =
let (x',y',w',h') = fromRectangle bounds
(_,_,innerW,innerH) = fromRectangle innerBounds
(doubleX,doubleY,doubleW,doubleH) = (fromIntegral x',fromIntegral y',fromIntegral w',fromIntegral h')
svg =
"<svg width=\"%d\" height=\"%d\" transform=\"translate(%f,%f)\">\n"
++ "<g>\n"
++ "<path d=\" M%d %d L %d %d L %d %d L %d %d\" stroke=\"%s\" stroke-width=\"%s\" fill=\"none\">\n"
++ "<path d=\" M%d %d L %d %d L %d %d L %d %d\" stroke=\"%s\" stroke-width=\"%s\" fill=\"none\">\n"
++ "<path d=\" M%d %d L %d %d\" stroke=\"black\" stroke-width=\"%s\" fill=\"none\">\n"
++ "<path d=\" M%d %d L %d %d\" stroke=\"black\" stroke-width=\"%s\" fill=\"none\">\n"
++ "</g>\n"
++ "</svg>"
xTranslation = (fromIntegral innerW) * v
yTranslation = (fromIntegral innerH) * v
in
if horizontal
then
printf svg
w' h' xTranslation (0 :: Double)
(0 :: Int) (0 :: Int)
(gaugeHeight spec) (0 :: Int)
(((gaugeHeight spec) `intDiv` 2) :: Int) ((truncate ((gaugeWidth spec)*(fromIntegral h'))) :: Int)
(0 :: Int) (0 :: Int)
("rgb(" ++ show borderR ++ "," ++ show borderG ++ "," ++ show borderB ++ ")") ("1px" :: String)
(0 :: Int) h'
(gaugeHeight spec) h'
(((gaugeHeight spec) `intDiv` 2) :: Int) (h'-(truncate ((gaugeWidth spec)*(fromIntegral h'))))
(0 :: Int) h'
("rgb(" ++ show borderR ++ "," ++ show borderG ++ "," ++ show borderB ++ ")") ("1px" :: String)
(0 :: Int) (0 :: Int)
(gaugeHeight spec) (0 :: Int)
("1px" :: String)
(0 :: Int) h'
(gaugeHeight spec) h'
("1px" :: String)
else
printf svg
w' h' (0 :: Double) yTranslation
(0 :: Int) (0 :: Int)
(0 :: Int) (gaugeHeight spec)
((truncate ((gaugeWidth spec)*(fromIntegral w'))) :: Int) (((gaugeHeight spec) `intDiv` 2) :: Int)
(0 :: Int) (0 :: Int)
("rgb(" ++ show borderR ++ "," ++ show borderG ++ "," ++ show borderB ++ ")") ("1px" :: String)
w' (0 :: Int)
w' (gaugeHeight spec)
(w'-(truncate ((gaugeWidth spec)*(fromIntegral w')))) (((gaugeHeight spec) `intDiv` 2) :: Int)
w' (0 :: Int)
("rgb(" ++ show borderR ++ "," ++ show borderG ++ "," ++ show borderB ++ ")") ("1px" :: String)
(0 :: Int) (0 :: Int)
(0 :: Int) (gaugeHeight spec)
("1px" :: String)
w' (0 :: Int)
w' (gaugeHeight spec)
("1px" :: String)
drawGauge innerBounds borderRgb bounds v horizontal spec =
let svg = gaugeSvg borderRgb bounds innerBounds v horizontal spec
(x,y,_,_) = fromRectangle bounds
in do
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,y))
LowLevel.destroy i
pillCornerRadius :: Int
pillCornerRadius = 2
pillLength :: Double
pillLength = 20.0
pillCenter :: Double
pillCenter = pillLength / 2.0
pillPadding :: Int
pillPadding = 3
pillEndPadding :: Int
pillEndPadding = 2
sliderValue :: Double -> Double -> Double -> Double
sliderValue min' max' curr' =
if (min' == max') then 0.5
else
case (curr' - min') / (max' - min') of
val | val > 1.0 -> 1.0
| val < 0.0 -> 0.0
| otherwise -> val
pillRectangle :: Bool -> Double -> Rectangle -> Rectangle
pillRectangle horizontal value' (Rectangle (Position (X x') (Y y')) (Size (Width w') (Height h'))) =
if horizontal
then
Rectangle
(Position
(X (truncate (fromIntegral x' + (fromIntegral w' - pillLength) * value')))
(Y (y'+ pillPadding)))
(Size
(Width (truncate pillLength))
(Height (h' - (pillPadding * 2) - 1)))
else
Rectangle
(Position
(X (x'+ pillPadding))
(Y (truncate (fromIntegral y' + ((fromIntegral h' - pillLength) * value')))))
(Size
(Width (w' - pillPadding*2 - 1))
(Height (truncate pillLength)))
drawPill rect v horizontal =
let (x,y,w,h) = fromRectangle rect
pill = pillRectangle
horizontal
v
(toRectangle
(if horizontal
then (x+pillEndPadding,y,w-2*pillEndPadding,h)
else (x,y+pillEndPadding,w,h-2*pillEndPadding)
)
)
in do
borderColor <- rgbColorWithRgb (0x93,0x93,0x93)
color <- sliderKnobColor
let pillVertices = mapM_ (LowLevel.flcVertex . toPrecisePosition) (roundedBoxPoints pill (Just pillCornerRadius) Nothing)
LowLevel.flcSetColor color
LowLevel.flcBeginPolygon
pillVertices
LowLevel.flcEndPolygon
LowLevel.flcSetColor borderColor
LowLevel.flcBeginLine
pillVertices
LowLevel.flcEndLine
{-# DEPRECATED fillSliderNew "Fill sliders are not supported in the Light theme. 'fillSliderNew' is the same as 'sliderNew'." #-}
{-# DEPRECATED horFillSliderNew "Fill sliders are not supported in the Light theme. 'horFillSliderNew' is the same as 'sliderNew'." #-}
{-# DEPRECATED horNiceSliderNew "\"Nice\"sliders are not supported in the Light theme. 'horNiceSliderNew' is the same as 'sliderNew'." #-}
sliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Slider)
sliderNew rectangle label = do
s <- LowLevel.sliderCustom
rectangle
label
(Just (\s -> do
bounds <- LowLevel.getRectangle s
drawSlider s Nothing bounds
))
(Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))
sliderSetup s
return s
gaugeSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.Slider)
gaugeSliderNew rectangle label = do
s <- LowLevel.sliderCustom
rectangle
label
(Just (\s -> do
bounds <- LowLevel.getRectangle s
drawSlider s (Just mkGaugeSliderSpec) bounds
))
(Just (LowLevel.defaultCustomWidgetFuncs {LowLevel.handleCustom = Just handleHover}))
sliderSetup (safeCast s)
return s
valueSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.ValueSlider)
valueSliderNew rectangle label = do
s <- LowLevel.valueSliderCustom
rectangle
label
(Just drawValueSlider)
(Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))
sliderSetup (safeCast s)
return s
horValueSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.HorValueSlider)
horValueSliderNew rectangle label = do
s <- LowLevel.valueSliderCustom
rectangle
label
(Just drawValueSlider)
(Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))
LowLevel.setType s HorSliderType
sliderSetup (safeCast s)
return (LowLevel.castTo s)
horSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.HorSlider)
horSliderNew rectangle label = do
s <- LowLevel.sliderCustom
rectangle
label
(Just (\s -> do
bounds <- LowLevel.getRectangle s
drawSlider s Nothing bounds
))
(Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))
LowLevel.setType s HorSliderType
sliderSetup (safeCast s)
return (LowLevel.castTo s)
fillSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.FillSlider)
fillSliderNew rectangle label = do
s <- LowLevel.sliderCustom
rectangle
label
(Just (\s -> do
bounds <- LowLevel.getRectangle s
drawSlider s Nothing bounds
))
(Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))
LowLevel.setType s VertFillSliderType
sliderSetup (safeCast s)
return (LowLevel.castTo s)
horFillSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.HorFillSlider)
horFillSliderNew rectangle label = do
s <- LowLevel.sliderCustom
rectangle
label
(Just (\s -> do
bounds <- LowLevel.getRectangle s
drawSlider s Nothing bounds
))
(Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))
sliderSetup (safeCast s)
LowLevel.setType s HorFillSliderType
return (LowLevel.castTo s)
horNiceSliderNew :: (?assets :: Assets) => Rectangle -> Maybe T.Text -> IO (Ref LowLevel.HorNiceSlider)
horNiceSliderNew rectangle label = do
s <- LowLevel.sliderCustom
rectangle
label
(Just (\s -> do
bounds <- LowLevel.getRectangle s
drawSlider s Nothing bounds
))
(Just (LowLevel.defaultCustomWidgetFuncs { LowLevel.handleCustom = (Just handleHover) }))
sliderSetup (safeCast s)
LowLevel.setType s HorNiceSliderType
return (LowLevel.castTo s)